haste-compiler 0.5.5.1 → 0.6.0.0
raw patch · 68 files changed
+344/−8262 lines, 68 filesdep +cryptonitedep +shellmate-extrasdep −data-binary-ieee754dep −monads-tfdep −websocketsdep ~basedep ~ghcdep ~network
Dependencies added: cryptonite, shellmate-extras
Dependencies removed: data-binary-ieee754, monads-tf, websockets
Dependency ranges changed: base, ghc, network, network-uri, process, shellmate
Files
- haste-compiler.cabal +47/−117
- lib/Foreign.js +1/−0
- lib/array.js +7/−11
- lib/rts.js +7/−3
- lib/spt.js +23/−0
- libraries/haste-lib/src/Haste.hs +0/−60
- libraries/haste-lib/src/Haste/Ajax.hs +0/−66
- libraries/haste-lib/src/Haste/App.hs +0/−30
- libraries/haste-lib/src/Haste/App/Client.hs +0/−156
- libraries/haste-lib/src/Haste/App/Concurrent.hs +0/−57
- libraries/haste-lib/src/Haste/App/Monad.hs +0/−301
- libraries/haste-lib/src/Haste/App/Protocol.hs +0/−56
- libraries/haste-lib/src/Haste/Audio.hs +0/−245
- libraries/haste-lib/src/Haste/Audio/Events.hs +0/−34
- libraries/haste-lib/src/Haste/Binary.hs +0/−348
- libraries/haste-lib/src/Haste/Binary/Get.hs +0/−179
- libraries/haste-lib/src/Haste/Binary/Put.hs +0/−157
- libraries/haste-lib/src/Haste/Binary/Types.hs +0/−109
- libraries/haste-lib/src/Haste/Compiler.hs +0/−84
- libraries/haste-lib/src/Haste/Compiler/Flags.hs +0/−61
- libraries/haste-lib/src/Haste/Concurrent.hs +0/−74
- libraries/haste-lib/src/Haste/Concurrent/Ajax.hs +0/−23
- libraries/haste-lib/src/Haste/Concurrent/Monad.hs +0/−173
- libraries/haste-lib/src/Haste/DOM.hs +0/−143
- libraries/haste-lib/src/Haste/DOM/Core.hs +0/−243
- libraries/haste-lib/src/Haste/DOM/JSString.hs +0/−218
- libraries/haste-lib/src/Haste/Events.hs +0/−24
- libraries/haste-lib/src/Haste/Events/BasicEvents.hs +0/−24
- libraries/haste-lib/src/Haste/Events/Core.hs +0/−99
- libraries/haste-lib/src/Haste/Events/KeyEvents.hs +0/−56
- libraries/haste-lib/src/Haste/Events/MouseEvents.hs +0/−61
- libraries/haste-lib/src/Haste/Events/TouchEvents.hs +0/−84
- libraries/haste-lib/src/Haste/Foreign.hs +0/−54
- libraries/haste-lib/src/Haste/Graphics/AnimationFrame.hs +0/−29
- libraries/haste-lib/src/Haste/Graphics/Canvas.hs +0/−454
- libraries/haste-lib/src/Haste/Hash.hs +0/−62
- libraries/haste-lib/src/Haste/JSON.hs +0/−194
- libraries/haste-lib/src/Haste/JSString.hs +0/−347
- libraries/haste-lib/src/Haste/LocalStorage.hs +0/−31
- libraries/haste-lib/src/Haste/Object.hs +0/−78
- libraries/haste-lib/src/Haste/Parsing.hs +0/−161
- libraries/haste-lib/src/Haste/Performance.hs +0/−16
- libraries/haste-lib/src/Haste/Random.hs +0/−106
- libraries/haste-lib/src/Haste/Serialize.hs +0/−176
- libraries/haste-lib/src/Haste/Timer.hs +0/−47
- libraries/haste-lib/src/Haste/WebSockets.hs +0/−92
- libraries/haste-prim/src/Haste/Prim.hs +0/−123
- libraries/haste-prim/src/Haste/Prim/Any.hs +0/−474
- libraries/haste-prim/src/Haste/Prim/Foreign.hs +0/−200
- libraries/haste-prim/src/Haste/Prim/JSType.hs +0/−287
- src/Haste/AST/Binary.hs +3/−3
- src/Haste/AST/Constructors.hs +0/−7
- src/Haste/AST/Optimize.hs +18/−11
- src/Haste/AST/PP.hs +19/−10
- src/Haste/AST/Print.hs +3/−2
- src/Haste/AST/Syntax.hs +6/−7
- src/Haste/CodeGen.hs +17/−16
- src/Haste/Config.hs +1/−1
- src/Haste/Environment.hs +0/−7
- src/Haste/Linker.hs +50/−20
- src/Haste/Module.hs +1/−6
- src/Haste/Monad.hs +30/−10
- src/Haste/PrimOps.hs +1/−2
- src/haste-boot.hs +80/−64
- src/hastec.hs +24/−25
- utils/haste-pkg/HastePkg708.hs +0/−1834
- utils/haste-pkg/HastePkg710.hs +6/−6
- utils/haste-pkg/haste-pkg.hs +0/−4
haste-compiler.cabal view
@@ -1,5 +1,5 @@ Name: haste-compiler-Version: 0.5.5.1+Version: 0.6.0.0 License: BSD3 License-File: LICENSE Synopsis: Haskell To ECMAScript compiler@@ -20,6 +20,7 @@ Homepage: http://haste-lang.org/ Bug-reports: http://github.com/valderman/haste-compiler/issues Stability: Experimental+Tested-With: GHC == 7.10.3 Data-Dir: lib@@ -44,6 +45,7 @@ floatdecode.js jsflow.js Foreign.js+ spt.js extra-source-files: include/primop-info-710.hs,@@ -61,25 +63,17 @@ portable. Default: False -Flag only-library- Description:- Only install the Haste server-side libraries; no binaries.- This is useful if you installed pre-built binaries but still want- to use Haste with vanilla GHC, for Haste.App for instance.- Default: False- source-repository head type: git location: https://github.com/valderman/haste-compiler.git Executable haste-boot- if flag(only-library)- buildable: False Main-Is: haste-boot.hs Other-Modules:- Haste.Version+ Haste.Args Haste.Environment Haste.GHCPaths+ Haste.Version Hs-Source-Dirs: src if flag(portable) CPP-Options: -DPORTABLE@@ -93,7 +87,8 @@ network, network-uri, HTTP,- shellmate >= 0.2.3 && <0.3,+ shellmate >= 0.3.2.2 && <0.4,+ shellmate-extras, ghc-paths, ghc, directory,@@ -101,8 +96,6 @@ Default-Language: Haskell98 Executable hastec- if flag(only-library)- buildable: False Hs-Source-Dirs: src Include-Dirs: include GHC-Options: -Wall -threaded@@ -115,9 +108,9 @@ if os(linux) GHC-Options: -static -optl-static -optl-pthread Build-Depends:- base < 5,+ base > 4.8 && < 5, ghc-prim,- ghc >= 7.8 && < 7.11,+ ghc >= 7.10 && < 8, mtl, binary, containers,@@ -127,10 +120,11 @@ ghc-paths, random, system-fileio,- shellmate >= 0.2.3 && <0.3,+ shellmate >= 0.3.2.2 && <0.4, either, filepath, directory,+ cryptonite >= 0.10 && < 1.0, ghc-simple >= 0.3 && < 0.4 Main-Is: hastec.hs@@ -167,15 +161,14 @@ Main-Is: haste-pkg.hs Other-Extensions: CPP Other-Modules:- HastePkg710- HastePkg708+ HastePkg710+ Haste.Environment+ Haste.GHCPaths+ Haste.Version Hs-Source-Dirs: src utils/haste-pkg - if flag(only-library)- buildable: False- if flag(portable) CPP-Options: -DPORTABLE @@ -186,30 +179,45 @@ if os(linux) GHC-Options: -static -optl-static -optl-pthread - Build-Depends: base >= 4 && < 5,- directory >= 1 && < 1.3,- process >= 1 && < 1.3,- Cabal >= 1.22 && < 1.24,- containers,- filepath,- binary,- bin-package-db,- bytestring,- shellmate >= 0.2.3 && <0.3,- ghc+ Build-Depends:+ base,+ directory >= 1 && < 1.3,+ process >= 1 && < 1.3,+ Cabal >= 1.22 && < 1.24,+ containers,+ filepath,+ binary,+ bin-package-db,+ bytestring,+ shellmate,+ ghc if !os(windows)- Build-Depends: unix,- terminfo+ Build-Depends:+ unix,+ terminfo if os(windows) c-sources: utils/haste-pkg/CRT_noglob.c Executable haste-cat- if flag(only-library)- buildable: False Main-Is: haste-cat.hs Other-Modules: Haste.Environment Haste.GHCPaths+ Haste.AST+ Haste.AST.Binary+ Haste.AST.Constructors+ Haste.AST.FlowAnalysis+ Haste.AST.Op+ Haste.AST.Optimize+ Haste.AST.PP+ Haste.AST.PP.Opts+ Haste.AST.Print+ Haste.AST.Syntax+ Haste.AST.Traversal+ Haste.Config+ Haste.JSLib+ Haste.Module+ Haste.Version Hs-Source-Dirs: src if flag(portable) CPP-Options: -DPORTABLE@@ -220,8 +228,8 @@ if os(linux) GHC-Options: -static -optl-static -optl-pthread Build-Depends:- base < 5,- shellmate >= 0.2.2 && <0.3,+ base,+ shellmate, ghc-paths, ghc, binary,@@ -234,81 +242,3 @@ directory, utf8-string default-language: Haskell98--Library- Hs-Source-Dirs: libraries/haste-lib/src, libraries/haste-prim/src, src- GHC-Options: -Wall -O2- Exposed-Modules:- Haste- Haste.Ajax- Haste.App- Haste.App.Concurrent- Haste.Audio- Haste.Binary- Haste.Compiler- Haste.Concurrent- Haste.DOM- Haste.DOM.JSString- Haste.Events- Haste.Foreign- Haste.Graphics.AnimationFrame- Haste.Graphics.Canvas- Haste.JSON- Haste.JSString- Haste.LocalStorage- Haste.Object- Haste.Parsing- Haste.Performance- Haste.Prim- Haste.Serialize- Haste.WebSockets- Other-Modules:- Haste.App.Client- Haste.App.Monad- Haste.App.Protocol- Haste.Audio.Events- Haste.Binary.Get- Haste.Binary.Put- Haste.Binary.Types- Haste.Compiler.Flags- Haste.Concurrent.Monad- Haste.Concurrent.Ajax- Haste.DOM.Core- Haste.Environment- Haste.Events.BasicEvents- Haste.Events.Core- Haste.Events.KeyEvents- Haste.Events.MouseEvents- Haste.Events.TouchEvents- Haste.GHCPaths- Haste.Hash- Haste.Prim.Any- Haste.Prim.Foreign- Haste.Prim.JSType- Haste.Random- Haste.Timer- Haste.Version- Paths_haste_compiler- Build-Depends:- transformers,- monads-tf,- containers,- base < 5,- ghc-prim,- random,- binary,- data-binary-ieee754,- bytestring,- utf8-string,- -- For Haste.Compiler- shellmate >= 0.2.2 && <0.3,- directory,- filepath,- process,- ghc-paths,- ghc,- directory,- websockets >= 0.9.1.0,- network >= 2.6,- network-uri >= 2.6- Default-Language: Haskell98
lib/Foreign.js view
@@ -22,6 +22,7 @@ var __app4 = function(f,a,b,c,d) {return f(a,b,c,d);} var __app5 = function(f,a,b,c,d,e) {return f(a,b,c,d,e);} var __jsNull = function() {return null;}+var __isUndef = function(x) {return typeof x == 'undefined';} var __eq = function(a,b) {return a===b;} var __createJSFunc = function(arity, f){ if(f instanceof Function && arity === f.length) {
lib/array.js view
@@ -11,11 +11,6 @@ // Create all views at once; perhaps it's wasteful, but it's better than having // to check for the right view at each read or write. function newByteArr(n) {- // Pad the thing to multiples of 8.- var padding = 8 - n % 8;- if(padding < 8) {- n += padding;- } return new ByteArray(new ArrayBuffer(n)); } @@ -30,15 +25,16 @@ } function ByteArray(buffer) {+ var len = buffer.byteLength; var views = { 'i8' : new Int8Array(buffer)- , 'i16': new Int16Array(buffer)- , 'i32': new Int32Array(buffer)+ , 'i16': len % 2 ? null : new Int16Array(buffer)+ , 'i32': len % 4 ? null : new Int32Array(buffer) , 'w8' : new Uint8Array(buffer)- , 'w16': new Uint16Array(buffer)- , 'w32': new Uint32Array(buffer)- , 'f32': new Float32Array(buffer)- , 'f64': new Float64Array(buffer)+ , 'w16': len % 2 ? null : new Uint16Array(buffer)+ , 'w32': len % 4 ? null : new Uint32Array(buffer)+ , 'f32': len % 4 ? null : new Float32Array(buffer)+ , 'f64': len % 8 ? null : new Float64Array(buffer) }; this['b'] = buffer; this['v'] = views;
lib/rts.js view
@@ -1,6 +1,10 @@ // This object will hold all exports. var Haste = {};-if(typeof window === 'undefined') window = global;+if(typeof window === 'undefined' && typeof global !== 'undefined') window = global;+window['__haste_crypto'] = window.crypto || window.msCrypto;+if(window['__haste_crypto'] && !window['__haste_crypto'].subtle && window.crypto.webkitSubtle) {+ window['__haste_crypto'].subtle = window.crypto.webkitSubtle;+} /* Constructor functions for small ADTs. */ function T0(t){this._=t;}@@ -353,8 +357,8 @@ /* Convert a JS exception into a Haskell JSException */ function __hsException(e) { e = e.toString();- var x = new Long(2904464383, 3929545892, true);- var y = new Long(3027541338, 3270546716, true);+ var x = new Long(738919189, 2683596561, true)+ var y = new Long(3648966346, 573393410, true); var t = new T5(0, x, y , new T5(0, x, y , unCStr("haste-prim")
+ lib/spt.js view
@@ -0,0 +1,23 @@+/* Code for creating and querying the static pointer table. */+window.__hs_spt = [];++function __spt_insert(ptr) {+ ptr = E(B(ptr));+ var ks = [ (ptr.a.a.low>>>0).toString(16)+ , (ptr.a.a.high>>>0).toString(16)+ , (ptr.a.b.low>>>0).toString(16)+ , (ptr.a.b.high>>>0).toString(16)+ ]+ var key = ks.join();+ window.__hs_spt[key] = ptr;+}++function hs_spt_lookup(k) {+ var ks = [ k['v']['w32'][0].toString(16)+ , k['v']['w32'][1].toString(16)+ , k['v']['w32'][2].toString(16)+ , k['v']['w32'][3].toString(16)+ ]+ var key = ks.join();+ return window.__hs_spt[key];+}
− libraries/haste-lib/src/Haste.hs
@@ -1,60 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, OverloadedStrings #-}--- | Haste's companion to the Prelude.------ Note that this module should *not* be imported together with--- "Haste.App", which provides the same functionality but slightly modified--- for automatic program slicing.-module Haste (- -- * Basic utility functions- JSString, JSAny, URL,- alert, prompt, eval, writeLog, catJSStr, fromJSStr,-- -- * URL hash handling- onHashChange, onHashChange', setHash, getHash, setHash', getHash',-- -- * Random number generation (deprecated; use the @random@ package instead)- Random (..), Seed, next, mkSeed, newSeed,-- -- * Timers- Timer, Interval (..), setTimer, stopTimer,-- -- * Fast conversions for JS-native types- JSType (..), JSNum (..), toString, fromString, convert- ) where-import Haste.Prim-import Haste.Timer-import Haste.Random-import Haste.Prim.JSType-import Haste.Hash-import Haste.Foreign-import Control.Monad.IO.Class--jsAlert :: String -> IO ()-jsAlert = ffi "alert"--jsLog :: String -> IO ()-jsLog = ffi "(function(x){console.log(x);})"--jsPrompt :: String -> IO String-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 => String -> m ()-alert = liftIO . jsAlert---- | Javascript prompt() function.-prompt :: MonadIO m => String -> m String-prompt = liftIO . jsPrompt---- | Javascript eval() function.-eval :: MonadIO m => JSString -> m JSString-eval = liftIO . jsEval---- | Use console.log to write a message.-writeLog :: MonadIO m => String -> m ()-writeLog = liftIO . jsLog
− libraries/haste-lib/src/Haste/Ajax.hs
@@ -1,66 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Low level XMLHttpRequest support. IE6 and older are not supported.-module Haste.Ajax (Method (..), URL, ajaxRequest, noParams) where-import Haste.Foreign-import Haste.Prim-import Haste.Prim.JSType-import Control.Monad.IO.Class-import Control.Monad (join)--ajaxReq :: Method -- method (GET/POST)- -> JSString -- URL- -> Bool -- async?- -> JSString -- POST data- -> (Maybe JSString -> IO ()) -- callback- -> IO ()-ajaxReq = ffi "(function(method, url, async, postdata, cb) {\- \var xhr = new XMLHttpRequest();\- \xhr.open(method, url, async);\- \if(method == 'POST') {\- \xhr.setRequestHeader('Content-type',\- \'application/x-www-form-urlencoded');\- \}\- \xhr.onreadystatechange = function() {\- \if(xhr.readyState == 4) {\- \cb(xhr.status == 200 ? xhr.responseText : null);\- \}\- \};\- \xhr.send(postdata);})"--data Method = GET | POST deriving Show--instance ToAny Method where- toAny GET = toAny ("GET" :: JSString)- toAny POST = toAny ("POST" :: JSString)---- | Pass to 'ajaxRequest' instead of @[]@ when no parameters are needed, to--- avoid type ambiguity errors.-noParams :: [((), ())]-noParams = []---- | Perform an AJAX request.-ajaxRequest :: (MonadIO m, JSType a, JSType b, JSType c)- => Method -- ^ GET or POST. For GET, pass all params in URL.- -- For POST, pass all params as post data.- -> URL -- ^ URL to make AJAX request to.- -> [(a, b)] -- ^ A list of (key, value) parameters.- -> (Maybe c -> IO ()) -- ^ Callback to invoke on completion.- -> m ()-ajaxRequest m url kv cb = liftIO $ do- _ <- ajaxReq m url' True pd (cb . join . fmap fromJSString)- return ()- where- url' = case m of- GET- | null kv -> toJSString url- | otherwise -> catJSStr "?" [toJSString url, toQueryString kv]- POST -> toJSString url- pd = case m of- GET -> ""- POST- | null kv -> ""- | otherwise -> toQueryString kv--toQueryString :: (JSType a, JSType b) =>[(a, b)] -> JSString-toQueryString = catJSStr "&" . map f- where f (k, v) = catJSStr "=" [toJSString k,toJSString v]
− libraries/haste-lib/src/Haste/App.hs
@@ -1,30 +0,0 @@--- | Type-safe client-server communication framework for Haste.------ In addition to the Haste.App extras, this module exports the same API as--- "Haste", modified slightly to work better with the automatic program--- slicing Haste.App provides. This means that you should import either this--- module *or* Haste, but *not* both.-module Haste.App (- MonadIO, Remotable, App, Server, Remote, Done,- Sessions, SessionID,- liftServerIO, forkServerIO, remote, runApp,- (<.>), getSessionID, getActiveSessions, onSessionEnd,- AppCfg, defaultConfig, cfgHost, cfgPort, mkConfig,- Client,- runClient, onServer, liftIO,- JSString, JSAny, URL, alert, prompt, eval, writeLog, catJSStr, fromJSStr,- module Haste.DOM.Core,- module Haste.Random,- module Haste.Prim.JSType,- module Haste.Hash,- module Haste.Binary- ) where-import Haste.App.Client-import Haste.App.Monad-import Haste.Binary (Binary (..))-import Haste.DOM.Core-import Haste.Random-import Haste.Prim.JSType-import Haste.Hash-import Haste-import Control.Monad.IO.Class
− libraries/haste-lib/src/Haste/App/Client.hs
@@ -1,156 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, MultiParamTypeClasses,- FlexibleInstances, CPP #-}-module Haste.App.Client (- Client, ClientState,- runClient, onServer, liftCIO, get, runClientCIO- ) where-import Haste-import Haste.WebSockets-import Haste.Events.Core-import Haste.Binary hiding (get)-import Haste.App.Monad-import Haste.App.Protocol-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import Control.Monad (ap, join)-import Control.Monad.IO.Class-import Control.Exception (throw)-import Data.IORef--data ClientState = ClientState {- csSendBlob :: MVar (Blob -> Client ()),- csNonce :: IORef Int,- csResultVars :: IORef [(Int, MVar Blob)]- }--initialState :: IORef Int- -> IORef [(Int,MVar Blob)]- -> MVar (Blob -> Client ())- -> ClientState-initialState n mv ws =- ClientState {- csSendBlob = ws,- csNonce = n,- csResultVars = mv- }---- | A client-side computation. See it as Haste.App's version of the IO monad.-newtype Client a = Client {- unC :: ClientState -> CIO a- }--instance Monad Client where- (Client m) >>= f = Client $ \cs -> do- x <- m cs- unC (f x) cs- return x = Client $ \_ -> return x--instance Functor Client where- fmap f (Client m) = Client $ \cs -> fmap f (m cs)--instance Applicative Client where- (<*>) = ap- pure = return--instance MonadIO Client where- liftIO m = Client $ \_ -> do- x <- liftIO m- return x--instance MonadBlob Client where- getBlobData = liftCIO . getBlobData- getBlobText' = liftCIO . getBlobText'--instance MonadEvent Client where- mkHandler f = do- st <- get id- return $ concurrent . runClientCIO st . f---- | Lift a CIO action into the Client monad.-liftCIO :: CIO a -> Client a-liftCIO m = Client $ \_ -> m >>= \x -> return x---- | Get part of the client state.-get :: (ClientState -> a) -> Client a-get f = Client $ \cs -> return (f cs)---- | Create a new nonce with associated result var.-newResult :: Client (Int, MVar Blob)-newResult = Client $ \cs -> do- mv <- newEmptyMVar- nonce <- liftIO $ atomicModifyIORef (csNonce cs) $ \n -> (n+1, n)- liftIO $ atomicModifyIORef (csResultVars cs) $ \vs -> ((nonce, mv):vs, ())- return (nonce, mv)---- | Run a Client computation in the web browser. The URL argument specifies--- the WebSockets URL the client should use to find the server.-runClient_ :: URL -> Client () -> IO ()-runClient_ url (Client m) = concurrent $ do- mv <- liftIO $ newIORef []- n <- liftIO $ newIORef 0- let errhandler = error "WebSockets connection died for some reason!"- openWS blob = do- wsvar <- get csSendBlob- liftCIO $ do- _ <- takeMVar wsvar- w <- withBinaryWebSocket url (handler mv) errhandler return- putMVar wsvar (liftCIO . wsSendBlob w)- wsSendBlob w blob- ws <- newMVar openWS- m (initialState n mv ws)- where- -- Find the result MVar corresponding to the nonce and write the result to- -- it, then discard the MVar.- handler rvars _ msg = do- msg' <- getBlobData msg- join . liftIO $ atomicModifyIORef rvars $ \vs ->- let res = do- case decode msg' :: Either String ServerException of- Right e -> throw e- _ -> return ()- ServerReply nonce result <- decode msg'- (var, vs') <- case span (\(n, _) -> n /= nonce) vs of- (xs, ((_, y):ys)) -> Right (y, xs ++ ys)- _ -> Left "Bad nonce!"- return (var, result, vs')- in case res of- Right (resvar, result, vs') -> (vs', putMVar resvar result)- _ -> (vs, return ())---- | Launch a client from a Server computation. runClient never returns before--- the program terminates.-runClient :: Client () -> App Done-runClient m = do- cfg <- getAppConfig- let url = "ws://" ++ cfgHost cfg ++ ":" ++ show (cfgPort cfg)- return . Done $ runClient_ url m---- | Run a client computation from the CIO monad, using a pre-specified state.-runClientCIO :: ClientState -> Client a -> CIO a-runClientCIO cs (Client m) = m cs---- | Perform a server-side computation, blocking the client thread until said--- computation returns.-onServer :: Binary a => Remote (Server a) -> Client a-#ifdef __HASTE__-onServer (Remote cid args) = __call cid (reverse args)-#else-onServer _ = undefined-#endif---- | Make a server-side call.-__call :: Binary a => CallID -> [Blob] -> Client a-__call cid args = do- send <- get csSendBlob >>= liftCIO . readMVar- (nonce, mv) <- newResult- send . encode $ ServerCall {- scNonce = nonce,- scMethod = cid,- scArgs = args- }- resblob <- liftCIO $ takeMVar mv- res <- getBlobData resblob- case decode res of- Right x -> return x- Left _ -> fail $ "Unable to decode return value!"
− libraries/haste-lib/src/Haste/App/Concurrent.hs
@@ -1,57 +0,0 @@-{-# LANGUAGE EmptyDataDecls #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | Wraps Haste.Concurrent to work with Haste.App.--- Task switching happens whenever a thread is blocked in an MVar, so things--- like polling an IORef in a loop will starve all other threads.------ This will likely be the state of Haste concurrency until Javascript gains--- decent native concurrency support.-module Haste.App.Concurrent (- C.MVar, CC.MBox, CC.Send, CC.Recv, CC.Inbox, CC.Outbox, C.MonadConc (..),- forkMany, newMVar, newEmptyMVar, takeMVar, putMVar, peekMVar, readMVar,- CC.spawn, CC.receive, CC.statefully, (CC.!), (CC.<!),- forever- ) where-import qualified Haste.Concurrent.Monad as C-import qualified Haste.Concurrent as CC-import Haste.App.Client-import Control.Monad--instance C.MonadConc Client where- liftConc = liftCIO- fork m = do- cs <- get id- liftCIO . C.forkIO $ runClientCIO cs m---- | Spawn several concurrent computations.-forkMany :: [Client ()] -> Client ()-forkMany = mapM_ C.fork---- | Create a new MVar with the specified contents.-newMVar :: a -> Client (C.MVar a)-newMVar = liftCIO . C.newMVar---- | Create a new empty MVar.-newEmptyMVar :: Client (C.MVar a)-newEmptyMVar = liftCIO C.newEmptyMVar---- | Read the value of an MVar. If the MVar is empty, @takeMVar@ blocks until--- a value arrives. @takeMVar@ empties the MVar.-takeMVar :: C.MVar a -> Client a-takeMVar = liftCIO . C.takeMVar---- | Put a value into an MVar. If the MVar is full, @putMVar@ will block until--- the MVar is empty.-putMVar :: C.MVar a -> a -> Client ()-putMVar v x = liftCIO $ C.putMVar v x---- | Read an MVar without affecting its contents.--- If the MVar is empty, @peekMVar@ immediately returns @Nothing@.-peekMVar :: C.MVar a -> Client (Maybe a)-peekMVar = liftCIO . C.peekMVar---- | 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 :: C.MVar a -> Client a-readMVar = liftCIO . C.readMVar
− libraries/haste-lib/src/Haste/App/Monad.hs
@@ -1,301 +0,0 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, PatternGuards #-}--- | Haste.App startup monad and configuration.-module Haste.App.Monad (- Remotable,- App, Server, Sessions, SessionID, Remote (..), Done (..),- AppCfg, defaultConfig, mkConfig, cfgHost, cfgPort,- liftServerIO, forkServerIO, remote, getAppConfig,- runApp, (<.>), getSessionID, getActiveSessions, onSessionEnd- ) where-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import Control.Monad (ap)-import Control.Monad.IO.Class-import Haste.Binary-import qualified Data.Map as M-import qualified Data.Set as S-import Haste.App.Protocol-import Data.Word-import Control.Concurrent (ThreadId)-import Data.IORef-import System.IO.Unsafe-#ifndef __HASTE__-import Haste.Binary.Types-import Control.Concurrent (forkIO)-import Network.WebSockets as WS-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.UTF8 as BU-import Control.Exception-import System.Random hiding (next)-import Data.List (foldl')-import Data.String-#endif--data AppCfg = AppCfg {- cfgHost :: String,- cfgPort :: Int,- cfgSessionEndHandlers :: [SessionID -> Server ()]- }--defaultConfig :: AppCfg-defaultConfig = mkConfig "localhost" 24601---- | Create a default configuration from a host name and a port number.-mkConfig :: String -> Int -> AppCfg-mkConfig host port = AppCfg {- cfgHost = host,- cfgPort = port,- cfgSessionEndHandlers = []- }--type SessionID = Word64-type Sessions = S.Set SessionID-type Method = [Blob] -> SessionID -> IORef Sessions -> IO Blob-type Exports = M.Map CallID Method-newtype Done = Done (IO ())--#ifdef __HASTE__-data Remote a = Remote CallID [Blob]-#else-data Remote a = Remote-#endif---- | Has 'runApp' already been invoked?-hasteAppRunning :: IORef Bool-hasteAppRunning = unsafePerformIO $ newIORef False---- | Apply an exported function to an argument.--- TODO: look into making this Applicative.-(<.>) :: Binary a => Remote (a -> b) -> a -> Remote b-#ifdef __HASTE__-(Remote cid args) <.> arg = Remote cid (encode arg:args)-#else-_ <.> _ = Remote-#endif---- | Application monad; allows for exporting functions, limited liftIO,--- forkIO and launching the client.-newtype App a = App {- unA :: AppCfg- -> IORef Sessions- -> CallID- -> Exports- -> IO (a, CallID, Exports, AppCfg)- }--instance Monad App where- return x = App $ \c _ cid exports -> return (x, cid, exports, c)- (App m) >>= f = App $ \cfg sessions cid exports -> do- res <- m cfg sessions cid exports- case res of- (x, cid', exports', cfg') -> unA (f x) cfg' sessions cid' exports'--instance Functor App where- fmap f m = m >>= return . f--instance Applicative App where- (<*>) = ap- pure = return---- | Lift an IO action into the Server monad, the result of which can only be--- used server-side.-liftServerIO :: IO a -> App (Server a)-#ifdef __HASTE__-liftServerIO _ = return Server-#else-liftServerIO m = App $ \cfg _ cid exports -> do- x <- m- return (return x, cid, exports, cfg)-#endif---- | Fork off a Server computation not bound an API call.--- This may be useful for any tasks that will keep running for as long as--- the server is running.------ Calling @getSessionID@ inside this computation will return 0, which will--- never be generated for an actual session. @getActiveSessions@ works as--- expected.-forkServerIO :: Server () -> App (Server ThreadId)-#ifdef __HASTE__-forkServerIO _ = return Server-#else-forkServerIO (Server m) = App $ \cfg sessions cid exports -> do- tid <- forkIO $ m 0 sessions- return (return tid, cid, exports, cfg)-#endif---- | An exportable function is of the type--- (Serialize a, ..., Serialize result) => a -> ... -> IO result-class Remotable a where- serializify :: a -> [Blob] -> (SessionID -> IORef Sessions -> IO Blob)--instance Binary a => Remotable (Server a) where-#ifdef __HASTE__- serializify _ _ = undefined-#else- serializify (Server m) _ = \sid ss -> fmap encode (m sid ss)-#endif--instance (Binary a, Remotable b) => Remotable (a -> b) where-#ifdef __HASTE__- serializify _ _ = undefined-#else- serializify f (x:xs) = serializify (f $! fromEither $ decode (toBD x)) xs- where- toBD (Blob x') = BlobData x'- fromEither (Right val) = val- fromEither (Left e) = error $ "Unable to deserialize data: " ++ e- serializify _ _ = error "The impossible happened in serializify!"-#endif---- | Make a function available to the client as an API call.-remote :: Remotable a => a -> App (Remote a)-#ifdef __HASTE__-remote _ = App $ \c _ cid _ ->- return (Remote cid [], cid+1, undefined, c)-#else-remote s = App $ \c _ cid exports ->- return (Remote, cid+1, M.insert cid (serializify s) exports, c)-#endif---- | Register a handler to be run whenever a session terminates.--- Several handlers can be registered at the same time; they will be run in--- the order they were registered.-onSessionEnd :: (SessionID -> Server ()) -> App ()-#ifdef __HASTE__-onSessionEnd _ = return ()-#else-onSessionEnd s = App $ \cfg _ cid exports -> return $- ((), cid, exports, cfg {cfgSessionEndHandlers = s:cfgSessionEndHandlers cfg})-#endif---- | Returns the application configuration.-getAppConfig :: App AppCfg-getAppConfig = App $ \cfg _ cid exports -> return (cfg, cid, exports, cfg)---- | Run a Haste.App application. runApp never returns before the program--- terminates.------ Note that @runApp@ is single-entry, and that its argument must not--- depend on any external IO. It is *strongly* recommended that the main--- function of any Haste.App program *only* consists of a single call to--- @runApp@.-runApp :: AppCfg -> App Done -> IO ()-runApp cfg (App s) = do- running <- atomicModifyIORef hasteAppRunning $ \r -> (True, r)- if running- then do- error "runApp is single-entry!"- else do-#ifdef __HASTE__- (Done client, _, _, _) <- s cfg undefined 0 undefined- client-#else- sessions <- newIORef S.empty- (_, _, exports, cfg') <- s cfg sessions 0 M.empty- serverEventLoop cfg' sessions exports-#endif--#ifndef __HASTE__--- | Server's communication event loop. Handles dispatching API calls.--- TODO: we could consider terminating a client who gets bad data, as that is--- a sure side of outside interference.-serverEventLoop :: AppCfg -> IORef Sessions -> Exports -> IO ()-serverEventLoop cfg sessions exports = do- WS.runServer "0.0.0.0" (cfgPort cfg) $ \pending -> do- conn <- acceptRequest pending- sid <- randomRIO (1, 0xFFFFFFFFFFFFFFFF)- atomicModifyIORef sessions $ \s -> (S.insert sid s, ())- clientLoop sid sessions conn- where- cleanup :: Connection -> SessionID -> IORef Sessions -> IO ()- cleanup conn deadsession sref = do- let f next m = unS (m deadsession) deadsession sref >> next- foldl' f (return ()) (cfgSessionEndHandlers cfg)- atomicModifyIORef sref $ \cs -> (S.delete deadsession cs, ())- let Blob bs = encode $ ServerException "Session ended"- sendTextData conn bs-- clientLoop :: SessionID -> IORef Sessions -> Connection -> IO ()- clientLoop sid sref c = finally go (cleanup c sid sref)- where- go = do- msg <- receiveData c- _ <- forkIO $ do- case decode (BlobData msg) of- Right (ServerCall nonce method args)- | Just m <- M.lookup method exports -> do- result <- m args sid sref- let Blob bs = encode $ ServerReply {- srNonce = nonce,- srResult = result- }- sendBinaryData c bs- _ -> do- error $ "Got bad method call: " ++ show msg- go-#endif---- | Server monad for Haste.App. Allows redeeming remote values, lifting IO--- actions, and not much more.-#ifdef __HASTE__-data Server a = Server-#else-newtype Server a = Server {unS :: SessionID -> IORef Sessions -> IO a}-#endif--instance Functor Server where-#ifdef __HASTE__- fmap _ _ = Server-#else- fmap f (Server m) = Server $ \sid ss -> f <$> m sid ss-#endif--instance Applicative Server where- (<*>) = ap- pure = return--instance Monad Server where-#ifdef __HASTE__- return _ = Server- _ >>= _ = Server-#else- return x = Server $ \_ _ -> return x- (Server m) >>= f = Server $ \sid ss -> do- Server m' <- f <$> m sid ss- m' sid ss-#endif--instance MonadIO Server where-#ifdef __HASTE__- liftIO _ = Server-#else- liftIO m = Server $ \_ _ -> m-#endif--instance MonadBlob Server where-#ifndef __HASTE__- getBlobData (Blob bd) = return $ BlobData bd- getBlobText' (Blob bd) = return $ fromString $ BU.toString $ BS.concat $ BSL.toChunks bd-#else- getBlobData _ = Server- getBlobText' _ = Server-#endif---- | Returns the ID of the current session.-getSessionID :: Server SessionID-#ifdef __HASTE__-getSessionID = Server-#else-getSessionID = Server $ \sid _ -> return sid-#endif---- | Return all currently active sessions.-getActiveSessions :: Server Sessions-#ifdef __HASTE__-getActiveSessions = Server-#else-getActiveSessions = Server $ \_ ss -> readIORef ss-#endif
− libraries/haste-lib/src/Haste/App/Protocol.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, CPP #-}--- | Haste.App client-server protocol.-module Haste.App.Protocol where-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import Control.Exception-import Data.Typeable-import Haste.Binary--type Nonce = Int-type CallID = Int---- | A method call to the server.-data ServerCall = ServerCall {- scNonce :: Nonce,- scMethod :: CallID,- scArgs :: [Blob]- }--instance Binary ServerCall where- {-# NOINLINE get #-}- get = do- n <- getWord8- if n == 0- then ServerCall <$> get <*> get <*> get- else fail "Wrong magic byte for ServerCall"- put (ServerCall n c as) = putWord8 0 >> put n >> put c >> put as---- | A reply to a ServerCall.-data ServerReply = ServerReply {- srNonce :: Nonce,- srResult :: Blob- }--instance Binary ServerReply where- {-# NOINLINE get #-}- get = do- n <- getWord8- if n == 1- then ServerReply <$> get <*> get- else fail "Wrong magic byte for ServerReply"- put (ServerReply n r) = putWord8 1 >> put n >> put r---- | Throw a server exception to the client.-data ServerException = ServerException String deriving (Typeable, Show)-instance Exception ServerException--instance Binary ServerException where- {-# NOINLINE get #-}- get = do- n <- getWord8- if n == 2- then ServerException <$> get- else fail "Wrong magic byte for ServerException"- put (ServerException e) = putWord8 2 >> put e
− libraries/haste-lib/src/Haste/Audio.hs
@@ -1,245 +0,0 @@-{-# 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.Foreign-import Haste.Prim.JSType-import Haste.Prim-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-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--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)
− libraries/haste-lib/src/Haste/Audio/Events.hs
@@ -1,34 +0,0 @@-{-# 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 ()
− libraries/haste-lib/src/Haste/Binary.hs
@@ -1,348 +0,0 @@-{-# LANGUAGE MagicHash, CPP, MultiParamTypeClasses, OverloadedStrings,- TypeSynonymInstances , FlexibleInstances,- GeneralizedNewtypeDeriving, BangPatterns, TypeOperators,- KindSignatures, DefaultSignatures, FlexibleInstances,- TypeSynonymInstances, FlexibleContexts, ScopedTypeVariables #-}--- | Handling of Javascript-native binary blobs.------ Generics borrowed from the binary package by Lennart Kolmodin (released under BSD3)-module Haste.Binary (- module Haste.Binary.Put,- module Haste.Binary.Get,- MonadBlob (..), Binary (..), getBlobText,- Blob, BlobData,- blobSize, blobDataSize, toByteString, fromByteString, toBlob, strToBlob,- encode, decode, decodeBlob- )where-import Data.Int-import Data.Word-import Data.Char-import GHC.Fingerprint.Type-import qualified Haste.JSString as J (length)-import Haste.Prim-import Haste.Concurrent-import Haste.Foreign hiding (get)-import Haste.Binary.Types-import Haste.Binary.Put-import Haste.Binary.Get-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import GHC.Generics-import Data.Bits-#ifndef __HASTE__-import qualified Data.ByteString.Lazy.Char8 as BS (unpack)-#endif--class Monad m => MonadBlob m where- -- | Retrieve the raw data from a blob.- getBlobData :: Blob -> m BlobData- -- | Interpret a blob as UTF-8 text, as a JSString.- getBlobText' :: Blob -> m JSString---- | Interpret a blob as UTF-8 text.-getBlobText :: MonadBlob m => Blob -> m String-getBlobText b = getBlobText' b >>= return . fromJSStr--instance MonadBlob CIO where-#ifdef __HASTE__- getBlobData b = 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 = 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---- | 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 = do- a <- get- b <- get- return (a, b)--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 = do- len <- getWord32le- getList len []- where- getList 0 xs = return $ reverse xs- getList n xs = get >>= \x -> getList (n-1) (x:xs)--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'---- | 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 String 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 :: (MonadBlob m, Binary a) => Blob -> m (Either String 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
− libraries/haste-lib/src/Haste/Binary/Get.hs
@@ -1,179 +0,0 @@-{-# 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-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import Control.Monad-import System.IO.Unsafe-#ifdef __HASTE__-import Haste.Foreign hiding (get)-#else-import qualified Control.Exception as Ex-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 !String-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 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 String a-runGet (Get p) (BlobData off len bd) = do- case p bd off 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 String a-runGet (Get g) (BlobData bd) = unsafePerformIO $ do- Ex.catch (Right <$> (return $! BG.runGet g bd)) mEx--mEx :: Ex.SomeException -> IO (Either String a)-mEx ex = return . Left $ 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
− libraries/haste-lib/src/Haste/Binary/Put.hs
@@ -1,157 +0,0 @@-{-# 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-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-#ifdef __HASTE__-import Control.Monad-import Haste.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
− libraries/haste-lib/src/Haste/Binary/Types.hs
@@ -1,109 +0,0 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, OverloadedStrings #-}-module Haste.Binary.Types (- Blob (..), BlobData (..),- blobSize, blobDataSize, toByteString, fromByteString, toBlob, strToBlob- ) where-import Haste.Prim-import Haste.Foreign-import qualified Data.ByteString.Lazy as BS-#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 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---- | 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
− libraries/haste-lib/src/Haste/Compiler.hs
@@ -1,84 +0,0 @@-{-# LANGUAGE CPP #-}--- | Yo dawg we heard you like Haste, so we let yo Haste programs compile yo--- Haste programs!------ Currently, this API calls the hastec binary. In the future it should--- probably be the other way around.-module Haste.Compiler (- module Haste.Compiler.Flags,- CompileResult (..), HasteOutput (..), HasteInput (..),- compile- ) where-import Haste.Compiler.Flags-#ifndef __HASTE__-import Control.Shell-import Haste.Environment-import Data.List (intercalate)-#endif--data CompileResult = Success HasteOutput | Failure String deriving Show-data HasteOutput = OutFile FilePath | OutString String deriving Show-data HasteInput = InFile FilePath | InString String deriving Show---- | Compile a Haste program using the given compiler flags and source--- directory.--- Calling this function from the client will always result in failure.-compile :: CompileFlags -> FilePath -> HasteInput -> IO CompileResult-#ifdef __HASTE__-compile _ _ _ = return $ Failure "Haste can only compile programs server-side."-#else-compile cf dir inp = do- eresult <- shell $ do- curdir <- pwd- inTempDirectory $ do- fil <- case inp of- InFile f -> return $ if isRelative f then incdir curdir </> f else f- InString s -> output "Main.hs" s >> return "Main.hs"- (f, _, e) <- genericRun hasteBinary (fil : idir curdir : mkFlags cf) ""- if f /= 0- then do- return $ Haste.Compiler.Failure e- else do- case cfTarget cf of- TargetFile tgt -> do- return $ Haste.Compiler.Success $ OutFile tgt- TargetString -> do- (Haste.Compiler.Success . OutString) `fmap` input "haste.out"- case eresult of- Right result ->- return result- Left e -> return $ Haste.Compiler.Failure $- "Run-time failure during compilation: " ++ exitString e- where- incdir cur = if isRelative dir then cur </> dir else dir- idir cur = "-i" ++ incdir cur---- | Turn flags into command line argument.-mkFlags :: CompileFlags -> [String]-mkFlags cf = concat [- case cfOptimize cf of- None -> ["-O0", "--ddisable-js-opts"]- Basic -> []- WholeProgram -> ["--opt-whole-program"],- case cfStart cf of- ASAP -> ["--onexec"]- OnLoad -> ["--onload"]- Custom s -> ["--start=" ++ s],- case cfTarget cf of- TargetFile fp -> ["--out=" ++ fp]- TargetString -> ["--out=haste.out"],- case cfMinify cf of- DontMinify -> []- Minify (Just p) fs -> ("--opt-minify="++p) : map appendMinifyFlag fs- Minify _ fs -> "--opt-minify" : map appendMinifyFlag fs,- when cfDebug "--debug",- when cfFullUnicode "--full-unicode",- when cfOwnNamespace "--separate-namespace",- when (not . null . cfJSFiles) ("--with-js=" ++ jsFileList),- when (not . cfUseStrict) "--no-use-strict"- ]- where- appendMinifyFlag f = "--opt-minify-flag=" ++ f- jsFileList = intercalate "," $ cfJSFiles cf- when opt arg = if opt cf then [arg] else []-#endif
− libraries/haste-lib/src/Haste/Compiler/Flags.hs
@@ -1,61 +0,0 @@-module Haste.Compiler.Flags (- OptLevel (..), ProgStart (..), HasteTarget (..), MinifyFlag (..),- ClosureOpt,- CompileFlags,- defaultFlags,- cfOptimize, cfDebug, cfMinify, cfFullUnicode, cfOwnNamespace, cfStart,- cfJSFiles, cfTarget, cfUseStrict- ) where-type ClosureOpt = String-data MinifyFlag = DontMinify | Minify (Maybe FilePath) [ClosureOpt]-data OptLevel = None | Basic | WholeProgram-data ProgStart = ASAP | OnLoad | Custom String-data HasteTarget = TargetFile FilePath | TargetString---- | Flags to pass to the compiler. Defaults are the same as when invoking--- hastec directly. Consult hastec --help for more detailed descriptions.-data CompileFlags = CompileFlags {- -- | How much should the given program be optimized?- -- Default: Basic- cfOptimize :: OptLevel,- -- | Should the output be debuggable? Debug information will be stripped- -- if the program is minified using Closure.- -- Default: False- cfDebug :: Bool,- -- | Should the program be minified? This will strip any debug information- -- from the resulting program.- -- Default: False- cfMinify :: MinifyFlag,- -- | Use full Unicode compatibility for Data.Char and friends?- -- Default: False- cfFullUnicode :: Bool,- -- | Put generated code in a separate namespace?- -- Default: False- cfOwnNamespace :: Bool,- -- | How should the program be started?- -- Default: OnLoad- cfStart :: ProgStart,- -- | Javascript files to include in the final program.- -- Default: []- cfJSFiles :: [FilePath],- -- | Where to place the compilation output.- -- Default: TargetString- cfTarget :: HasteTarget,- -- | @'use strict';@?- -- Default: True- cfUseStrict :: Bool- }---- | Default compiler flags.-defaultFlags :: CompileFlags-defaultFlags = CompileFlags {- cfOptimize = Basic,- cfDebug = False,- cfMinify = DontMinify,- cfFullUnicode = False,- cfOwnNamespace = False,- cfStart = OnLoad,- cfJSFiles = [],- cfTarget = TargetString,- cfUseStrict = True- }
− libraries/haste-lib/src/Haste/Concurrent.hs
@@ -1,74 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeFamilies,- EmptyDataDecls #-}--- | Concurrency for Haste. Includes MVars, forking, Ajax and more.-module Haste.Concurrent (- module Haste.Concurrent.Monad, module Ajax,- Recv, Send, Inbox, Outbox, MBox,- receive, spawn, statefully, (!), (<!),- wait- ) where-import Haste.Concurrent.Monad-import Haste.Concurrent.Ajax as Ajax-import Haste.Timer---- | Wait for n milliseconds.-wait :: Int -> CIO ()-wait ms = do- v <- newEmptyMVar- _ <- liftIO $ setTimer (Once ms) $ concurrent $ putMVar v ()- takeMVar v---- | An MBox is a read/write-only MVar, depending on its first type parameter.--- Used to communicate with server processes.-newtype MBox t a = MBox (MVar a)--data Recv-data Send--type Inbox = MBox Recv-type Outbox = MBox Send---- | Block until a message arrives in a mailbox, then return it.-receive :: MonadConc m => Inbox a -> m a-receive (MBox mv) = liftConc $ takeMVar mv---- | Creates a generic process and returns a MBox which may be used to pass--- messages to it.--- While it is possible for a process created using spawn to transmit its--- inbox to someone else, this is a very bad idea; don't do it.-spawn :: MonadConc m => (Inbox a -> m ()) -> m (Outbox a)-spawn f = do- p <- liftConc newEmptyMVar- fork $ f (MBox p)- return (MBox p)---- | Creates a generic stateful process. This process is a function taking a--- state and an event argument, returning an updated state or Nothing.--- @statefully@ creates a @MBox@ that is used to pass events to the process.--- Whenever a value is written to this MBox, that value is passed to the--- process function together with the function's current state.--- If the process function returns Nothing, the process terminates.--- If it returns a new state, the process again blocks on the event MBox,--- and will use the new state to any future calls to the server function.-statefully :: MonadConc m => st -> (st -> evt -> m (Maybe st)) -> m (Outbox evt)-statefully initialState handler = do- spawn $ loop initialState- where- loop st p = do- mresult <- liftConc (receive p) >>= handler st- case mresult of- Just st' -> loop st' p- _ -> return ()---- | Write a value to a MBox. Named after the Erlang message sending operator,--- as both are intended for passing messages to processes.--- This operation does not block until the message is delivered, but returns--- immediately.-(!) :: MonadConc m => Outbox a -> a -> m ()-MBox m ! x = liftConc $ forkIO $ putMVar m x---- | Perform a Client computation, then write its return value to the given--- pipe. Mnemonic: the operator is a combination of <- and !.--- Just like @(!)@, this operation is non-blocking.-(<!) :: MonadConc m => Outbox a -> m a -> m ()-p <! m = do x <- m ; p ! x
− libraries/haste-lib/src/Haste/Concurrent/Ajax.hs
@@ -1,23 +0,0 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances #-}--- | Concurrent Ajax calls. IE6 and older are not supported.-module Haste.Concurrent.Ajax (- Method (..), URL, noParams,- Haste.Concurrent.Ajax.ajaxRequest- ) where-import Haste.Concurrent.Monad-import Haste.Ajax-import Haste.Prim.JSType---- | Make a blocking AJAX request in the CIO monad.--- Note that unlike using the browser's native blocking AJAX facilities,--- this does *not* freeze the browser.-ajaxRequest :: (JSType a, JSType b, JSType c)- => Method -- ^ GET or POST. For GET, pass all params in URL.- -- For POST, pass all params as post data.- -> URL -- ^ URL to make AJAX request to.- -> [(a, b)] -- ^ A list of (key, value) parameters.- -> CIO (Maybe c)-ajaxRequest method url kv = do- v <- newEmptyMVar- liftIO $ Haste.Ajax.ajaxRequest method url kv $ concurrent . putMVar v- takeMVar v
− libraries/haste-lib/src/Haste/Concurrent/Monad.hs
@@ -1,173 +0,0 @@-{-# LANGUAGE GADTs, TypeFamilies, FlexibleInstances, FlexibleContexts, CPP #-}--- | Implements concurrency for Haste based on "A Poor Man's Concurrency Monad".-module Haste.Concurrent.Monad (- MVar, CIO, ToConcurrent (..), MonadConc (..),- forkIO, forkMany, newMVar, newEmptyMVar, takeMVar, putMVar, withMVarIO,- peekMVar, modifyMVarIO, readMVar, concurrent, liftIO- ) where-import Control.Monad.IO.Class-import Control.Monad.Cont.Class-import Control.Monad-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import Data.IORef-import Haste.Events.Core (MonadEvent (..))---- | Any monad which supports concurrency.-class Monad m => MonadConc m where- liftConc :: CIO a -> m a- fork :: m () -> m ()--instance MonadConc CIO where- liftConc = id- fork = forkIO--instance MonadEvent CIO where- mkHandler = return . fmap concurrent---- | Embed concurrent computations into non-concurrent ones.-class ToConcurrent a where- type Async a- async :: Async a -> a--instance ToConcurrent (IO ()) where- type Async (IO ()) = CIO ()- async = concurrent--instance ToConcurrent (CIO ()) where- type Async (CIO ()) = CIO ()- async = id--instance ToConcurrent b => ToConcurrent (a -> b) where- type Async (a -> b) = a -> Async b- async f = \x -> async (f x)--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---- | Concurrent IO monad. The normal IO monad does not have concurrency--- capabilities with Haste. This monad is basically IO plus concurrency.-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)--instance MonadCont CIO where- callCC f = C $ \next -> unC (f (\a -> C $ \_ -> next a)) next---- | Spawn a new thread.-forkIO :: CIO () -> CIO ()-forkIO (C m) = C $ \next -> Fork [next (), m (const Stop)]---- | Spawn several threads at once.-forkMany :: [CIO ()] -> CIO ()-forkMany ms = C $ \next -> Fork (next () : [act (const Stop) | C act <- ms])---- | Create a new MVar with an initial value.-newMVar :: MonadIO m => a -> m (MVar a)-newMVar a = liftIO $ MVar `fmap` newIORef (Full a [])---- | Create a new empty MVar.-newEmptyMVar :: MonadIO m => m (MVar a)-newEmptyMVar = liftIO $ MVar `fmap` newIORef (Empty [])---- | Read an MVar. Blocks if the MVar is empty.--- Only the first writer in the write queue, if any, is woken.-takeMVar :: MVar a -> CIO a-takeMVar (MVar ref) =- 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)---- | Peek at the value inside a given MVar, if any, without removing it.-peekMVar :: MonadIO m => MVar a -> m (Maybe a)-peekMVar (MVar ref) = liftIO $ do- v <- readIORef ref- case v of- Full x _ -> return (Just x)- _ -> return Nothing---- | 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 :: MVar a -> CIO a-readMVar m = do- x <- takeMVar m- putMVar m x- return x---- | Write an MVar. Blocks if the MVar is already full.--- Only the first reader in the read queue, if any, is woken.-putMVar :: MVar a -> a -> CIO ()-putMVar (MVar ref) x =- 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 $ next ()---- | Perform an IO action over an MVar.-withMVarIO :: MVar a -> (a -> IO b) -> CIO b-withMVarIO v m = takeMVar v >>= liftIO . m---- | Perform an IO action over an MVar, then write the MVar back.-modifyMVarIO :: MVar a -> (a -> IO (a, b)) -> CIO b-modifyMVarIO v m = do- (x, res) <- withMVarIO v m- putMVar v x- return res---- | 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 (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 ()
− libraries/haste-lib/src/Haste/DOM.hs
@@ -1,143 +0,0 @@-{-# LANGUAGE GADTs #-}--- | DOM manipulation functions using 'String' for string representation.-module Haste.DOM (- -- From Haste.DOM.Core- AttrName (..), Attribute, IsElem (..), Elem (..),- attribute, set, with, children,- click, focus, blur, document, documentBody, appendChild, addChild,- addChildBefore, insertChildBefore, getFirstChild, getLastChild, getChildren,- setChildren, clearChildren, deleteChild, removeChild,- -- Own exports- PropID, ElemID, QuerySelector, ElemClass, AttrValue,- prop, style, attr, (=:),- newElem, newTextElem,- elemById, elemsByQS, elemsByClass,- setProp, getProp, setAttr, getAttr, J.getValue,- withElem , withElems, withElemsQS, mapQS, mapQS_,- getStyle, setStyle,- J.getFileData, getFileName,- setClass, toggleClass, hasClass- ) 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)---- | 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)---- | 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
− libraries/haste-lib/src/Haste/DOM/Core.hs
@@ -1,243 +0,0 @@-{-# 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,- deleteChild, clearChildren,- setChildren, getChildren,- getLastChild, getFirstChild, getChildBefore,- insertChildBefore, appendChild,- -- Low level stuff- jsSet, jsSetAttr, jsSetStyle,- -- Deprecated- removeChild, addChild, addChildBefore- ) where-import Haste.Prim-import Control.Monad.IO.Class-import Haste.Foreign-import Data.String--jsSet :: Elem -> JSString -> JSString -> IO ()-jsSet = ffi "(function(e,p,v){e[p] = v;})"--jsSetAttr :: Elem -> JSString -> JSString -> IO ()-jsSetAttr = ffi "(function(e,p,v){e.setAttribute(p, v);})"--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 :: Elem -> IO (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"---- | 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)--{-# DEPRECATED addChild "Use appendChild instead. Note that appendChild == flip addChild." #-}--- | Append the first element as a child of the second element.-addChild :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> m ()-addChild = flip appendChild---- | 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)--{-# DEPRECATED addChildBefore "Use insertChildBefore instead. Note insertChildBefore == \\parent new old -> addChildBefore new parent old." #-}--- | Insert an element into a container, before another element.--- For instance:--- @--- addChildBefore childToAdd theContainer olderChild--- @-addChildBefore :: (IsElem parent, IsElem child, MonadIO m)- => child -> parent -> child -> m ()-addChildBefore child parent oldChild = insertChildBefore parent oldChild child---- | 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)--{-# DEPRECATED removeChild "Use deleteChild instead. Note that deleteChild = flip removeChild." #-}--- | DEPRECATED: use 'deleteChild' instead!--- Note that @deleteChild = flip removeChild@.-removeChild :: (IsElem parent, IsElem child, MonadIO m)- => child- -> parent- -> m ()-removeChild = flip deleteChild
− libraries/haste-lib/src/Haste/DOM/JSString.hs
@@ -1,218 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}--- | DOM manipulation functions using 'JSString' for string representation.-module Haste.DOM.JSString (- -- From Haste.DOM.Core- AttrName (..), Attribute, IsElem (..), Elem (..),- attribute, set, with, children,- click, focus, blur, document, documentBody, appendChild, addChild,- addChildBefore, insertChildBefore, getFirstChild, getLastChild, getChildren,- setChildren, clearChildren, deleteChild, removeChild,- -- Own exports- PropID, ElemID, QuerySelector, ElemClass, AttrValue,- prop, style, attr, (=:),- newElem, newTextElem,- elemById, elemsByQS, elemsByClass,- setProp, getProp, setAttr, getAttr, getValue,- withElem , withElems, withElemsQS, mapQS, mapQS_,- getStyle, setStyle,- getFileData, getFileName,- setClass, toggleClass, hasClass- ) where-import Haste.Prim-import Haste.Prim.JSType-import Haste.DOM.Core-import Data.Maybe (isNothing, fromJust)-import Control.Monad.IO.Class-import Haste.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') {\- \return [];\- \} 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---- | 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---- | 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);})"
− libraries/haste-lib/src/Haste/Events.hs
@@ -1,24 +0,0 @@--- | Event handling for Haste.-module Haste.Events (- -- * Core event functionality- Event (..), MonadEvent (..),- HandlerInfo,- unregisterHandler, onEvent, preventDefault,-- -- * Basic events with no arguments- BasicEvent (..),-- -- * Keyboard-related events- KeyEvent (..), KeyData (..), mkKeyData,-- -- * Mouse-related events- MouseEvent (..), MouseData (..), MouseButton (..),-- -- * Touch-related events- TouchEvent (..), TouchData (..), Touch (..)- ) 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
− libraries/haste-lib/src/Haste/Events/BasicEvents.hs
@@ -1,24 +0,0 @@-{-# 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--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"- eventData _ _ = return ()
− libraries/haste-lib/src/Haste/Events/Core.hs
@@ -1,99 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleContexts #-}--- | Basic framework for event handling.-module Haste.Events.Core (- Event (..), MonadEvent (..),- HandlerInfo,- unregisterHandler, onEvent, preventDefault- ) where-import Haste.Prim-import Haste.DOM.Core-import Haste.Foreign-import Control.Monad.IO.Class-import Data.IORef-import System.IO.Unsafe---- | 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 :: Elem,- -- | 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 :: IO ()-preventDefault = readIORef evtRef >>= go- where- go :: Maybe JSAny -> IO ()- go = ffi "(function(e){if(e){e.preventDefault();}})"---- | Set an event handler on a DOM element.-onEvent :: (MonadEvent m, IsElem 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 = elemOf 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 :: Elem -> 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 :: Elem -> JSString -> JSAny -> IO ()-unregEvt = ffi "(function(e,name,f){e.removeEventListener(name,f[0]);})"
− libraries/haste-lib/src/Haste/Events/KeyEvents.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, CPP #-}--- | Events relating to mouse keyboard input.-module Haste.Events.KeyEvents (KeyEvent (..), KeyData (..), mkKeyData) where-import Haste.Prim.Any-import Haste.Events.Core-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif---- | 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"
− libraries/haste-lib/src/Haste/Events/MouseEvents.hs
@@ -1,61 +0,0 @@-{-# 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.Foreign-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif--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"
− libraries/haste-lib/src/Haste/Events/TouchEvents.hs
@@ -1,84 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies, CPP #-}--- | Events relating to touch input.-module Haste.Events.TouchEvents (- TouchEvent (..), TouchData (..), Touch (..)- ) where-import Haste.Prim.Any-import Haste.Foreign-import Haste.Events.Core-import Haste.DOM.Core-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif--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];})"
− libraries/haste-lib/src/Haste/Foreign.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE CPP, OverloadedStrings #-}--- | High level JavaScript foreign interface.-module Haste.Foreign (- -- * Conversion to/from JSAny- ToAny (..), FromAny (..), JSAny,- Opaque, toOpaque, fromOpaque,- nullValue, toObject, has, get, index,- getMaybe, hasAll, lookupAny, JSException (..),-- -- * Importing and exporting JavaScript functions- FFI, JSFunc,- ffi, constant, export-#if __GLASGOW_HASKELL__ >= 710- , safe_ffi, StaticPtr-#endif- ) where-import Haste.Prim.Foreign-import Haste.Prim (JSString)-import qualified Haste.JSString as J-import Control.Monad (foldM)-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative ((<$>), pure)-#endif---- | 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"
− libraries/haste-lib/src/Haste/Graphics/AnimationFrame.hs
@@ -1,29 +0,0 @@-{-# 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.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"
− libraries/haste-lib/src/Haste/Graphics/Canvas.hs
@@ -1,454 +0,0 @@-{-# 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-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import Control.Monad.IO.Class-import Data.Maybe (fromJust)-import Haste-import Haste.DOM.JSString-import Haste.DOM.Core-import Haste.Concurrent (CIO) -- for SPECIALISE pragma-import Haste.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 JSString-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" (toJSString 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 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 $ do- fromJSStr <$> 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
− libraries/haste-lib/src/Haste/Hash.hs
@@ -1,62 +0,0 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts, GADTs, OverloadedStrings #-}--- | Hash manipulation and callbacks.-module Haste.Hash (- onHashChange, onHashChange', setHash, getHash, setHash', getHash'- ) where-import Haste.Foreign-import Control.Monad.IO.Class-import Haste.Prim---- | 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 :: MonadIO m- => (String -> String -> IO ())- -> m ()-onHashChange f = do- firsthash <- getHash'- liftIO $ jsOnHashChange firsthash cb- where- cb = \old new -> f (fromJSStr old) (fromJSStr new)---- | JSString version of @onHashChange@.-onHashChange' :: MonadIO m- => (JSString -> JSString -> IO ())- -> m ()-onHashChange' f = do- 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 => String -> m ()-setHash = liftIO . jsSetHash . toJSStr---- | Set the hash part of the current URL - JSString version.-setHash' :: MonadIO m => JSString -> m ()-setHash' = liftIO . jsSetHash--jsSetHash :: JSString -> IO ()-jsSetHash = ffi "(function(h) {location.hash = '#'+h;})"---- | Read the hash part of the currunt URL.-getHash :: MonadIO m => m String-getHash = liftIO $ fromJSStr `fmap` jsGetHash---- | Read the hash part of the currunt URL - JSString version.-getHash' :: MonadIO m => m JSString-getHash' = liftIO jsGetHash--jsGetHash :: IO JSString-jsGetHash = ffi "(function() {return location.hash.substring(1);})"
− libraries/haste-lib/src/Haste/JSON.hs
@@ -1,194 +0,0 @@-{-# 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__-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import Haste.Parsing-#endif-import Haste.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 . show--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 String 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
− libraries/haste-lib/src/Haste/JSString.hs
@@ -1,347 +0,0 @@-{-# 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 (- -- * 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- ) 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)-import Data.String-import Haste.Prim-import Haste.Prim.Foreign--#ifdef __HASTE__-import GHC.Prim-import System.IO.Unsafe--{-# 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 = veryUnsafePerformIO $ cmap_js (_jss_singleton . f) s--{-# INLINE _jss_cmap #-}-_jss_cmap :: (Char -> JSString) -> JSString -> JSString-_jss_cmap f s = veryUnsafePerformIO $ 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 = veryUnsafePerformIO $ _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))---- | 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)---- | 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
− libraries/haste-lib/src/Haste/LocalStorage.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE OverloadedStrings, CPP #-}--- | Basic bindings to HTML5 WebStorage.-module Haste.LocalStorage (setItem, getItem, removeItem) where-import Haste-import Haste.Foreign-import Haste.Serialize-import Haste.JSON-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif---- | Locally store a serializable value.-setItem :: Serialize a => String -> a -> IO ()-setItem k = store k . encodeJSON . toJSON--store :: String -> 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 => String -> IO (Either String a)-getItem k = do- maybe (Left "No such value") (\s -> decodeJSON s >>= fromJSON) <$> load k--load :: String -> IO (Maybe JSString)-load = ffi "(function(k) {return localStorage.getItem(k);})"---- | Remove a value from local storage.-removeItem :: String -> IO ()-removeItem = ffi "(function(k) {localStorage.removeItem(k);})"
− libraries/haste-lib/src/Haste/Object.hs
@@ -1,78 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, TypeSynonymInstances,- FlexibleInstances, MagicHash, GeneralizedNewtypeDeriving, CPP #-}--- | Dealing with JavaScript objects on a low, low level.-module Haste.Object (- JSObj, Type (..),- (#), asString, asBool, asNumber, typeOf, lookupPath, toObject- ) where-import Haste.Prim-import Haste.Foreign---- | A JS object: either null/undefined or 'Just' an actual value.-type JSObj = Maybe JSAny---- | Possible types of JS objects.-data Type = TUndefined | TNumber | TBoolean | TString | TFunction | TObject- deriving (Show, Eq, Enum)--instance FromAny Type where- fromAny = fmap toEnum . fromAny---- | Any type on which we can look up a JS property.-class JSLookup a where- infixl 4 #- -- | Look up a property on an object-like value.- (#) :: a -> JSString -> IO JSObj--instance JSLookup JSObj where- Just o # prop = look o prop- _ # _ = return Nothing--instance JSLookup a => JSLookup (IO a) where- o # prop = o >>= (# prop)---- | Lookup a whole path at once. More efficient for long paths.--- @x `lookupPath` ["a", "b"]@ is equivalent to @x.a.b@.-lookupPath :: JSObj -> [JSString] -> IO JSObj-lookupPath = ffi "(function(o,as){\- for(var i in as){\- o = o[as[i]];\- if(typeof o==='undefined'){return null;}\- }\- return o;})"--look :: JSAny -> JSString -> IO (Maybe JSAny)-look = ffi "(function(o,s){return o[s] === undefined ? null : o[s];})"---- | Convert the object to a 'JSString'.-asString :: JSObj -> IO (Maybe JSString)-asString = maybe (return Nothing) go- where- go = ffi "(function(o){return String(o);})"---- | Convert the object to a 'Bool'.-asBool :: JSObj -> IO (Maybe Bool)-asBool = maybe (return Nothing) go- where- go = ffi "(function(o){return Boolean(o);})"---- | Convert the object to a 'Double'.-asNumber :: JSObj -> IO (Maybe Double)-asNumber = maybe (return Nothing) go- where- go = ffi "(function(o){return Number(o);})"---- | Get the type of a JS object.-typeOf :: JSObj -> IO Type-typeOf = maybe (return TUndefined) go- where- go = ffi "(function(o){\- switch(typeof o){\- case 'undefined': return 0;\- case 'number': return 1;\- case 'boolean': return 2;\- case 'string': return 3;\- case 'function': return 4;\- default: return 5;\- }\- })"
− libraries/haste-lib/src/Haste/Parsing.hs
@@ -1,161 +0,0 @@-{-# 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, ())
− libraries/haste-lib/src/Haste/Performance.hs
@@ -1,16 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | (Very incomplete) Haste bindings to the @Performance@ DOM interface.-module Haste.Performance (HRTimeStamp, now, navigationStart) where-import Haste.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;})"
− libraries/haste-lib/src/Haste/Random.hs
@@ -1,106 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, CPP, OverloadedStrings #-}-module Haste.Random (Random (..), Seed, next, mkSeed, newSeed) where-import Haste.Prim.JSType-import Data.Int-import Data.Word-import Data.List (unfoldr)-import Control.Monad.IO.Class-import System.IO.Unsafe-#ifdef __HASTE__-import Haste.Foreign-#else-import qualified System.Random as SR-#endif--#ifdef __HASTE__--newtype Seed = Seed JSAny deriving (ToAny, FromAny)--nxt :: Seed -> IO Seed-nxt = ffi "(function(s){\-var ba = window['newByteArr'](16);\-ba['v']['w32'][0] = s[0];\-ba['v']['w32'][1] = s[1];\-ba['v']['w32'][2] = s[2];\-ba['v']['w32'][3] = s[3];\-return window['md51'](ba,16);})"--getN :: Seed -> IO Int-getN = ffi "(function(s){return s[0];})"--toSeed :: Int -> IO Seed-toSeed = ffi "(function(n){\-var ba = window['newByteArr'](16);\-ba['v']['w32'][0] = n;\-return window['md51'](ba,16);})"--createSeed :: IO Seed-createSeed = ffi "(function(){\-var ba = window['newByteArr'](16);\-ba['v']['f64'][0] = Math.random();\-ba['v']['f64'][1] = Math.random();\-return window['md51'](ba,16);})"-#else-newtype Seed = Seed (Int, SR.StdGen)--nxt :: Seed -> IO Seed-nxt (Seed (_, g)) = return . Seed $ SR.next g--getN :: Seed -> IO Int-getN (Seed (n, _)) = return n--toSeed :: Int -> IO Seed-toSeed = return . Seed . SR.next . SR.mkStdGen--createSeed :: IO Seed-createSeed = SR.newStdGen >>= return . Seed . SR.next-#endif---- | Create a new seed from an integer.-mkSeed :: Int -> Seed-mkSeed = unsafePerformIO . toSeed---- | Generate a new seed using JavaScript's PRNG.-newSeed :: MonadIO m => m Seed-newSeed = liftIO createSeed---- | Generate the next seed in the sequence.-next :: Seed -> Seed-next = unsafePerformIO . nxt--class Random a where- -- | Generate a pseudo random number between a lower (inclusive) and higher- -- (exclusive) bound.- randomR :: (a, a) -> Seed -> (a, Seed)- randomRs :: (a, a) -> Seed -> [a]- randomRs bounds seed = unfoldr (Just . randomR bounds) seed--instance Random Int where- randomR (low, high) s- | low <= high =- let n = unsafePerformIO $ getN s- in (n `mod` (high-low+1) + low, next s)- | otherwise =- randomR (high, low) s--instance Random Int32 where- randomR (l,h) seed =- case randomR (convert l :: Int, convert h) seed of- (n, s) -> (convert n, s)--instance Random Word where- randomR (l,h) seed =- case randomR (convert l :: Int, convert h) seed of- (n, s) -> (convert n, s)--instance Random Word32 where- randomR (l,h) seed =- case randomR (convert l :: Int, convert h) seed of- (n, s) -> (convert n, s)--instance Random Double where- randomR (low, high) seed =- (f * (high-low) + low, s)- where- (n, s) = randomR (0, 2000000001 :: Int) seed- f = convert n / 2000000000
− libraries/haste-lib/src/Haste/Serialize.hs
@@ -1,176 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings, CPP #-}--- | 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.Prim (JSString, toJSStr, fromJSStr)-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import Control.Monad (ap)--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 $ toJSStr [c]- parseJSON (Str s) =- case fromJSStr s of- [c] -> return c- _ -> fail "Tried to deserialize long string to a Char"- parseJSON _ =- fail "Tried to deserialize a non-string to a Char"- listToJSON = toJSON . toJSStr- parseJSONList s = fmap fromJSStr (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 String a-fromJSON = runParser parseJSON---- | Type for JSON parser.-newtype Parser a = Parser (Either String a)--runParser :: (a -> Parser b) -> a -> Either String 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--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 $ "Key not found: " ++ fromJSStr 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
− libraries/haste-lib/src/Haste/Timer.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE OverloadedStrings, CPP #-}-module Haste.Timer (Timer, Interval (..), setTimer, stopTimer) where-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import Control.Monad.IO.Class-import Haste.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){window.setTimeout(f,t);})"--interval :: Int -> IO () -> IO Int-interval = ffi "(function(t,f){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);})"
− libraries/haste-lib/src/Haste/WebSockets.hs
@@ -1,92 +0,0 @@-{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving#-}--- | WebSockets API for Haste.-module Haste.WebSockets (- module Haste.Concurrent,- WebSocket,- withWebSocket, withBinaryWebSocket, wsSend, wsSendBlob- ) where-import Haste-import Haste.Foreign-import Haste.Concurrent-import Haste.Binary (Blob)--newtype WebSocket = WebSocket JSAny deriving (ToAny, FromAny)---- | Run a computation with a web socket. The computation will not be executed--- until a connection to the server has been established.-withWebSocket :: URL- -- ^ URL to bind the WebSocket to- -> (WebSocket -> JSString -> CIO ())- -- ^ Computation to run when new data arrives- -> CIO a- -- ^ Computation to run when an error occurs- -> (WebSocket -> CIO a)- -- ^ Computation using the WebSocket- -> CIO a-withWebSocket url cb err f = do- result <- newEmptyMVar- let f' = \ws -> concurrent $ f ws >>= putMVar result- liftIO $ new url cb' f' $ concurrent $ err >>= putMVar result- takeMVar result- where- cb' = \ws msg -> concurrent $ cb ws msg---- | Run a computation with a web socket. The computation will not be executed--- until a connection to the server has been established.-withBinaryWebSocket :: URL- -- ^ URL to bind the WebSocket to- -> (WebSocket -> Blob -> CIO ())- -- ^ Computation to run when new data arrives- -> CIO a- -- ^ Computation to run when an error occurs- -> (WebSocket -> CIO a)- -- ^ Computation using the WebSocket- -> CIO a-withBinaryWebSocket url cb err f = do- result <- newEmptyMVar- let f' = \ws -> concurrent $ f ws >>= putMVar result- liftIO $ newBin url cb' f' $ concurrent $ err >>= putMVar result- takeMVar result- where- cb' = \ws msg -> concurrent $ cb ws msg--new :: URL- -> (WebSocket -> JSString -> IO ())- -> (WebSocket -> IO ())- -> IO ()- -> IO ()-new = ffi "(function(url, cb, f, err) {\- \var ws = new WebSocket(url);\- \ws.onmessage = function(e) {cb(ws,e.data);};\- \ws.onopen = function(e) {f(ws);};\- \ws.onerror = function(e) {err());};\- \return ws;\- \})" --newBin :: URL- -> (WebSocket -> Blob -> IO ())- -> (WebSocket -> IO ())- -> IO ()- -> IO ()-newBin = ffi "(function(url, cb, f, err) {\- \var ws = new WebSocket(url);\- \ws.binaryType = 'blob';\- \ws.onmessage = function(e) {cb(ws,e.data);};\- \ws.onopen = function(e) {f(ws);};\- \ws.onerror = function(e) {err();};\- \return ws;\- \})" ---- | Send a string over a WebSocket.-wsSend :: WebSocket -> JSString -> CIO ()-wsSend ws str = liftIO $ sendS ws str---- | Send a Blob over a WebSocket.-wsSendBlob :: WebSocket -> Blob -> CIO ()-wsSendBlob ws b = liftIO $ sendB ws b--sendS :: WebSocket -> JSString -> IO ()-sendS = ffi "(function(s, msg) {s.send(msg);})"--sendB :: WebSocket -> Blob -> IO ()-sendB = ffi "(function(s, msg) {s.send(msg);})"
− libraries/haste-prim/src/Haste/Prim.hs
@@ -1,123 +0,0 @@-{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface, MagicHash, - TypeSynonymInstances, FlexibleInstances, CPP, UnboxedTuples #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Haste.Prim (- JSString (..), URL, toJSStr, fromJSStr, catJSStr, JSAny (..),- Ptr, toPtr, fromPtr, veryUnsafePerformIO) where-import Foreign.Ptr-import Data.String-#ifdef __HASTE__-import Unsafe.Coerce-import GHC.CString-import qualified GHC.HastePrim as HP-#else-import Data.List (intercalate)-#endif-import GHC.Prim-import GHC.Types (IO (..))--type URL = String---- | Any JS value, with one layer of indirection.-newtype JSAny = JSAny (Ptr Any)--instance Eq JSAny where- (==) = __eq--{-# INLINE veryUnsafePerformIO #-}--- | Strict, inlineable, dupable version of 'unsafePerformIO'. Only use if you--- are extremely sure this is not a problem. So please don't.-veryUnsafePerformIO :: IO a -> a-veryUnsafePerformIO (IO act) =- case act realWorld# of- (# _, x #) -> x---- | Concatenate a series of JSStrings using the specified separator.-catJSStr :: JSString -> [JSString] -> JSString-#ifdef __HASTE__-foreign import ccall jsCat :: Ptr [JSString] -> JSString -> JSString-foreign import ccall __eq :: JSAny -> JSAny -> Bool-catJSStr sep strs = jsCat (toPtr strs) sep-#else-catJSStr sep strs = toJSStr $ intercalate (fromJSStr sep) (map fromJSStr strs)-__eq :: JSAny -> JSAny -> Bool-__eq _ _ = undefined-#endif--#ifdef __HASTE__-foreign import ccall strEq :: JSString -> JSString -> Bool-foreign import ccall strOrd :: JSString -> JSString -> Ptr Ordering---- | Native JavaScript strings.-newtype JSString = JSString JSAny--instance Eq JSString where- (==) = strEq--instance Ord JSString where- compare a b = fromPtr (strOrd a b)--instance Show JSString where- show = fromJSStr---- | In normal Haskell, we use Storable for data that can be pointed to. When--- we compile to JS, however, anything can be "pointed" to and nothing needs--- to be stored.-toPtr :: a -> Ptr a-toPtr = unsafeCoerce---- | Unwrap a "pointer" to something.-fromPtr :: Ptr a -> a-fromPtr = unsafeCoerce--{-# RULES "toJSS/fromJSS" forall s. toJSStr (fromJSStr s) = s #-}-{-# RULES "fromJSS/toJSS" forall s. fromJSStr (toJSStr s) = s #-}-{-# RULES "toJSS/unCSTR" forall s. toJSStr (unpackCString# s) =- JSString (JSAny (toPtr (unsafeCoerce# s))) #-}-{-# RULES "toJSS/unCSTRU8" forall s. toJSStr (unpackCStringUtf8# s) =- JSString (JSAny (toPtr (unsafeCoerce# s))) #-}---- | Convert a 'String' to a 'JSString'.-{-# NOINLINE [1] toJSStr #-}-toJSStr :: String -> JSString-toJSStr = unsafeCoerce# HP.toJSStr--instance IsString JSString where- fromString = toJSStr---- | Convert a 'JSString' to a 'String'.-{-# NOINLINE [1] fromJSStr #-}-fromJSStr :: JSString -> String-fromJSStr = unsafeCoerce# HP.fromJSStr--#else---- | JSStrings are represented as normal strings server-side; should probably--- be changed to ByteString or Text.-newtype JSString = JSString String--instance IsString JSString where- fromString = JSString--instance Eq JSString where- (JSString a) == (JSString b) = a == b--instance Ord JSString where- (JSString a) `compare` (JSString b) = a `compare` b--instance Show JSString where- show = fromJSStr--toJSStr :: String -> JSString-toJSStr = JSString--fromJSStr :: JSString -> String-fromJSStr (JSString s) = s--toPtr :: a -> Ptr a-toPtr = error "toPtr used in native code!"--fromPtr :: Ptr a -> a-fromPtr = error "fromPtr used in native code!"--#endif
− libraries/haste-prim/src/Haste/Prim/Any.hs
@@ -1,474 +0,0 @@--- For the FFI-{-# LANGUAGE ForeignFunctionInterface, PatternGuards, CPP, BangPatterns #-}---- For generic default instances-{-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleInstances,- FlexibleContexts, OverloadedStrings, DefaultSignatures #-}--#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif---- For less annoying instances-{-# LANGUAGE TupleSections #-}---- | Converting to/from JS-native data.-module Haste.Prim.Any (- ToAny (..), FromAny (..), Generic, JSAny (..),- Opaque, toOpaque, fromOpaque,- nullValue, toObject, has, get, index- ) where-import GHC.Generics-import Control.Exception-import Haste.Prim-import Haste.Prim.JSType-import Data.Int-import Data.Word-import Unsafe.Coerce-import System.IO.Unsafe -- for toObject-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif--#ifdef __HASTE__-foreign import ccall __lst2arr :: Ptr [a] -> JSAny-foreign import ccall __arr2lst :: Int -> JSAny -> Ptr [a]-foreign import ccall "String" jsString :: JSAny -> JSString-foreign import ccall "Number" jsNumber :: JSAny -> Double-foreign import ccall __jsNull :: IO JSAny-foreign import ccall __new :: IO JSAny-foreign import ccall __set :: JSAny -> JSString -> JSAny -> IO ()-foreign import ccall __get :: JSAny -> JSString -> IO JSAny-foreign import ccall __has :: JSAny -> JSString -> IO Bool-#else-__new :: IO JSAny-__new = return undefined-__get :: JSAny -> JSString -> IO JSAny-__get _ _ = return undefined-__set :: JSAny -> JSString -> JSAny -> IO ()-__set _ _ _ = return ()-__has :: JSAny -> JSString -> IO Bool-__has _ _ = return False-__lst2arr :: Ptr [a] -> JSAny-__lst2arr _ = undefined-__arr2lst :: Int -> JSAny -> Ptr [a]-__arr2lst _ _ = undefined-jsString :: JSAny -> JSString-jsString _ = undefined-jsNumber :: JSAny -> Double-jsNumber _ = undefined-__jsNull :: IO JSAny-__jsNull = undefined-#endif--{-# NOINLINE jsNull #-}-jsNull :: JSAny-jsNull = unsafePerformIO __jsNull--{-- For theoretical purposes, imagine the following here:- foreign import ccall __intToAny :: Int -> JSAny- ...- In practice, however, we use unsafeCoerce for that to avoid the roundtrip.--}---- | The JS value null.-nullValue :: JSAny-nullValue = jsNull---- | Build a new JS object from a list of key:value pairs.-toObject :: [(JSString, JSAny)] -> JSAny-toObject ps = veryUnsafePerformIO $ do- o <- __new- mapM_ (uncurry $ __set o) ps- return o---- | Read a member from a JS object. Throws an error if the member can not be--- marshalled into a value of type @a@.-{-# INLINE get #-}-get :: FromAny a => JSAny -> JSString -> IO a-get o k = __get o k >>= fromAny--{-# INLINE index #-}--- | Read an element from a JS array. Throws an error if the member can not be--- marshalled into a value of type @a@.-index :: FromAny a => JSAny -> Int -> IO a-index o k = __get o (unsafeCoerce k) >>= fromAny---- | Check if a JS object has a particular member.-{-# INLINE has #-}-has :: JSAny -> JSString -> IO Bool-has = __has---- | Any type that can be converted into a JavaScript value.-class ToAny a where- -- | Build a JS object from a Haskell value.- --- -- The default instance creates an object from any type that derives- -- 'Generic' according to the following rules:- --- -- * Records turn into plain JS objects, with record names as field names.- --- -- * Non-record product types turn into objects containing a @$data@ field- -- which contains all of the constructor's unnamed fields.- --- -- * Values of enum types turn into strings matching their constructors.- --- -- * Non-enum types with more than one constructor gain an extra field,- -- @$tag@, which contains the name of the constructor used to create the- -- object.- --- toAny :: a -> JSAny- default toAny :: (GToAny (Rep a), Generic a) => a -> JSAny- toAny x =- case gToAny False g of- Tree x' -> toObject x'- One x' -> if isEnum g then x' else toAny [x']- List x' -> toAny x'- where g = from x-- listToAny :: [a] -> JSAny- listToAny = __lst2arr . toPtr . map toAny---- | Any type that can be converted from a JavaScript value.-class FromAny a where- -- | Convert a value from JS with a reasonable conversion if an exact match- -- is not possible. Examples of reasonable conversions would be truncating- -- floating point numbers to integers, or turning signed integers into- -- unsigned.- --- -- The default instance is the inverse of the default 'ToAny' instance.- fromAny :: JSAny -> IO a- default fromAny :: (GToAny (Rep a), GFromAny (Rep a), Generic a)- => JSAny -> IO a- fromAny x = to <$> gFromAny False x-- listFromAny :: JSAny -> IO [a]- listFromAny = mapM fromAny . fromPtr . __arr2lst 0---- | The Opaque type is inhabited by values that can be passed to JavaScript--- using their raw Haskell representation. Opaque values are completely--- useless to JS code, and should not be inspected. This is useful for,--- for instance, storing data in some JS-native data structure for later--- retrieval.-newtype Opaque a = Opaque {fromOpaque :: a}--toOpaque :: a -> Opaque a-toOpaque = Opaque------ ToAny instances-instance ToAny JSAny where toAny = unsafeCoerce-instance ToAny (Ptr a) where toAny = unsafeCoerce-instance ToAny JSString where toAny = unsafeCoerce-instance ToAny Int where toAny = unsafeCoerce-instance ToAny Int8 where toAny = unsafeCoerce-instance ToAny Int16 where toAny = unsafeCoerce-instance ToAny Int32 where toAny = unsafeCoerce-instance ToAny Word where toAny = unsafeCoerce-instance ToAny Word8 where toAny = unsafeCoerce-instance ToAny Word16 where toAny = unsafeCoerce-instance ToAny Word32 where toAny = unsafeCoerce-instance ToAny Float where toAny = unsafeCoerce-instance ToAny Double where toAny = unsafeCoerce-instance ToAny Char where- toAny = unsafeCoerce- listToAny = toAny . toJSStr-instance ToAny () where- toAny _ = jsNull-instance ToAny (Opaque a) where- toAny (Opaque x) = unsafeCoerce $ toPtr x-instance ToAny Bool where- toAny = unsafeCoerce---- | Lists are marshalled into arrays, with the exception of 'String'.-instance ToAny a => ToAny [a] where- toAny = listToAny---- | Maybe is simply a nullable type. Nothing is equivalent to null, and any--- non-null value is equivalent to x in Just x.-instance ToAny a => ToAny (Maybe a) where- toAny Nothing = jsNull- toAny (Just x) = toAny x---- | Tuples are marshalled into arrays.-instance (ToAny a, ToAny b) => ToAny (a, b) where- toAny (a, b) = toAny [toAny a, toAny b]--instance (ToAny a, ToAny b, ToAny c) => ToAny (a, b, c) where- toAny (a, b, c) = toAny [toAny a, toAny b, toAny c]--instance (ToAny a, ToAny b, ToAny c, ToAny d) =>- ToAny (a, b, c, d) where- toAny (a, b, c, d) = toAny [toAny a, toAny b, toAny c, toAny d]--instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e) =>- ToAny (a, b, c, d, e) where- toAny (a, b, c, d, e) = toAny [toAny a,toAny b,toAny c,toAny d,toAny e]--instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e,- ToAny f) => ToAny (a, b, c, d, e, f) where- toAny (a, b, c, d, e, f) =- toAny [toAny a, toAny b, toAny c, toAny d, toAny e, toAny f]--instance (ToAny a, ToAny b, ToAny c, ToAny d, ToAny e,- ToAny f, ToAny g) => ToAny (a, b, c, d, e, f, g) where- toAny (a, b, c, d, e, f, g) =- toAny [toAny a,toAny b,toAny c,toAny d,toAny e,toAny f,toAny g]----instance FromAny JSAny where- fromAny x = return (unsafeCoerce x)-instance FromAny (Ptr a) where- fromAny x = return (unsafeCoerce x)-instance FromAny JSString where- fromAny x = return (jsString x)-instance FromAny Int where- fromAny x = return (convert (jsNumber x))-instance FromAny Int8 where- fromAny x = return (convert (jsNumber x))-instance FromAny Int16 where- fromAny x = return (convert (jsNumber x))-instance FromAny Int32 where- fromAny x = return (convert (jsNumber x))-instance FromAny Word where- fromAny x = return (convert (jsNumber x))-instance FromAny Word8 where- fromAny x = return (convert (jsNumber x))-instance FromAny Word16 where- fromAny x = return (convert (jsNumber x))-instance FromAny Word32 where- fromAny x = return (convert (jsNumber x))---- unsafeCoerce for Float and Double saves a lot on performance, and only--- differs in semantics if the value in question is a) not a number, and--- b) passed verbatim back into JS land-instance FromAny Float where- fromAny x = return (unsafeCoerce x)-instance FromAny Double where- fromAny x = return (unsafeCoerce x)--instance FromAny Char where- fromAny x = return (unsafeCoerce (jsNumber x))- listFromAny x = fromJSStr <$> fromAny x-instance FromAny () where- fromAny _ = return ()-instance FromAny (Opaque a) where- fromAny x = Opaque . fromPtr <$> fromAny x-instance FromAny Bool where- fromAny = return . unsafeCoerce--instance FromAny a => FromAny [a] where- fromAny = listFromAny--instance FromAny a => FromAny (Maybe a) where- fromAny x | x == jsNull = return Nothing- | otherwise = Just <$> fromAny x--instance (FromAny a, FromAny b) => FromAny (a, b) where- fromAny x = do- [a,b] <- fromAny x- (,) <$> fromAny a <*> fromAny b--instance (FromAny a, FromAny b, FromAny c) => FromAny (a, b, c) where- fromAny x = do- [a,b,c] <- fromAny x- (,,) <$> fromAny a <*> fromAny b <*> fromAny c--instance (FromAny a, FromAny b, FromAny c, FromAny d) =>- FromAny (a, b, c, d) where- fromAny x = do- [a,b,c,d] <- fromAny x- (,,,) <$> fromAny a <*> fromAny b <*> fromAny c <*> fromAny d--instance (FromAny a, FromAny b, FromAny c, FromAny d, FromAny e) =>- FromAny (a, b, c, d, e) where- fromAny x = do- [a,b,c,d,e] <- fromAny x- (,,,,) <$> fromAny a <*> fromAny b <*> fromAny c- <*> fromAny d <*> fromAny e--instance (FromAny a, FromAny b, FromAny c, FromAny d, FromAny e, FromAny f) =>- FromAny (a, b, c, d, e, f) where- fromAny x = do- [a,b,c,d,e,f] <- fromAny x- (,,,,,) <$> fromAny a <*> fromAny b <*> fromAny c- <*> fromAny d <*> fromAny e <*> fromAny f--instance (FromAny a, FromAny b, FromAny c, FromAny d,- FromAny e, FromAny f, FromAny g) =>- FromAny (a, b, c, d, e, f, g) where- fromAny x = do- [a,b,c,d,e,f,g] <- fromAny x- (,,,,,,) <$> fromAny a <*> fromAny b <*> fromAny c <*> fromAny d- <*> fromAny e <*> fromAny f <*> fromAny g--data Value = One !JSAny | List ![JSAny] | Tree ![(JSString, JSAny)]---- GToAny instances-class GToAny f where- gToAny :: Bool -> f a -> Value- isEnum :: f a -> Bool--instance GToAny U1 where- gToAny _ U1 = error "U1: unpossible!"- isEnum _ = True--instance ToAny a => GToAny (K1 i a) where- gToAny _ (K1 x) = One (toAny x)- isEnum _ = False--instance (Selector c, GToAny a) => GToAny (M1 S c a) where- gToAny mcs (M1 x) = do- case name of- "" -> One value- _ -> Tree [(name, value)]- where name = toJSStr (selName (undefined :: M1 S c a ()))- value =- case gToAny mcs x of- Tree x' -> toObject x'- One x' -> toAny x'- List x' -> toAny x'- isEnum _ = isEnum (undefined :: a ())--instance Constructor c => GToAny (M1 C c U1) where- gToAny _ _ = One (toAny $ conName (undefined :: M1 C c U1 ()))- isEnum _ = True--#if __GLASGOW_HASKELL__ < 710-instance (Constructor c, GToAny a) => GToAny (M1 C c a) where-#else-instance {-# OVERLAPPABLE #-} (Constructor c, GToAny a) =>- GToAny (M1 C c a) where-#endif- gToAny many_constrs (M1 x)- | many_constrs =- case args of- Tree args' -> Tree (("$tag", toAny tag) : args')- One arg -> Tree [("$tag", toAny tag), ("$data", arg)]- List args' -> Tree [("$tag", toAny tag), ("$data", toAny args')]- | otherwise =- args- where- tag = conName (undefined :: M1 C c a ())- args = gToAny many_constrs x- isEnum _ = isEnum (undefined :: a ())--instance GToAny a => GToAny (M1 D c a) where- gToAny cs (M1 x) = gToAny cs x- isEnum _ = isEnum (undefined :: a ())--instance (GToAny a, GToAny b) => GToAny (a :*: b) where- gToAny cs (a :*: b) =- case (gToAny cs a, gToAny cs b) of- (One l, One r) -> List [l, r]- (One x, List xs) -> List (x:xs)- (List xs, One x) -> List (xs ++ [x])- (List l, List r) -> List (l ++ r)- (Tree l, Tree r) -> Tree (l ++ r)- (_, _) -> error "Tree :*: non-tree!"- isEnum _ = False--instance (GToAny a, GToAny b) => GToAny (a :+: b) where- gToAny _ (L1 x) = gToAny True x- gToAny _ (R1 x) = gToAny True x- isEnum _ = isEnum (undefined :: a ()) && isEnum (undefined :: b ())-------- GFromAny instances-class GFromAny f where- gFromAny :: Bool -> JSAny -> IO (f a)- isRecord :: f a -> Bool- gFromList :: Int -> JSAny -> IO (f a, Int)- gFromList = error "gFromList called on non-product!"--instance GFromAny U1 where- gFromAny _ _ = return U1- isRecord _ = False--instance (ToAny a, FromAny a) => GFromAny (K1 i a) where- gFromAny _ x = do- x' <- fromAny x- return $ K1 x'- isRecord _ = False- gFromList ix x = do- x' <- x `index` ix- return (K1 x', ix+1)--instance (Selector c, GFromAny a) => GFromAny (M1 S c a) where- gFromAny mcs x = do- exists <- x `has` prop- if exists- then M1 <$> (get x prop >>= gFromAny mcs)- else error $ "No such member: '" ++ sn ++ "'"- where- sn = selName (undefined :: M1 S c a ())- prop = toJSStr sn- isRecord _ = not (null $ selName (undefined :: M1 S c a ()))- gFromList ix x = do- (x', ix') <- gFromList ix x- return (M1 x', ix')--instance Constructor c => GFromAny (M1 C c U1) where- gFromAny _ x = do- n <- fromAny x- if (n == cn)- then return $ M1 U1- else error $ "Couldn't fromAny constructor: expected " ++ cn- ++ " but got " ++ n- where- cn = conName (undefined :: M1 C c U1 ())- isRecord _ = False--#if __GLASGOW_HASKELL__ < 710-instance (Constructor c, GFromAny a) => GFromAny (M1 C c a) where-#else-instance {-# OVERLAPPABLE #-} (Constructor c, GFromAny a) =>- GFromAny (M1 C c a) where-#endif- gFromAny many_constrs x- | many_constrs = do- t <- x `get` "$tag"- if t == tag- then M1 <$> (x `get` "$data" >>= gFromAny many_constrs)- else error $ "Couldn't fromAny constructor: expected " ++ tag- ++ " but got " ++ t- | isRecord (undefined :: a ()) = do- M1 <$> gFromAny many_constrs x- | otherwise = do- M1 . fst <$> gFromList 0 x- where- tag = conName (undefined :: M1 C c a ())- isRecord _ = isRecord (undefined :: a ())--instance GFromAny a => GFromAny (M1 D c a) where- gFromAny cs x = M1 <$> gFromAny cs x- isRecord _ = isRecord (undefined :: a ())- gFromList ix x = do- (x', ix') <- gFromList ix x- return (M1 x', ix')--instance (GFromAny a, GFromAny b) => GFromAny (a :*: b) where- gFromAny cs x = do- a <- gFromAny cs x- b <- gFromAny cs x- return (a :*: b)- isRecord _ = isRecord (undefined :: a ())- gFromList ix x = do- (a, ix') <- gFromList ix x- (b, ix'') <- gFromList ix' x- return (a :*: b, ix'')--instance (GFromAny a, GFromAny b) => GFromAny (a :+: b) where- gFromAny _ x = do- catch (L1 <$> gFromAny True x)- (withSomeException $ R1 <$> gFromAny True x)- isRecord _ = isRecord (undefined :: a ()) || isRecord (undefined :: b ())--withSomeException :: IO a -> SomeException -> IO a-withSomeException m _ = m
− libraries/haste-prim/src/Haste/Prim/Foreign.hs
@@ -1,200 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, BangPatterns, CPP #-}-{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE DeriveDataTypeable #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif--- | High level JavaScript foreign interface.-module Haste.Prim.Foreign (- module Haste.Prim.Any,- FFI, JSFunc, JSException (..),- ffi, constant, export-#if __GLASGOW_HASKELL__ >= 710- , safe_ffi, StaticPtr-#endif- ) where-import Haste.Prim-import Haste.Prim.Any-#if __GLASGOW_HASKELL__ >= 710-import GHC.StaticPtr (StaticPtr, deRefStaticPtr)-#endif-import Unsafe.Coerce-import Control.Exception-import Data.Typeable---- | A JS function.-type JSFun = JSAny--#ifdef __HASTE__-foreign import ccall __strict :: JSAny -> JSAny-foreign import ccall "eval" __eval :: JSString -> JSFun-foreign import ccall __apply :: JSFun -> Ptr [JSAny] -> IO JSAny-foreign import ccall __app0 :: JSFun -> IO JSAny-foreign import ccall __app1 :: JSFun -> JSAny -> IO JSAny-foreign import ccall __app2 :: JSFun -> JSAny -> JSAny -> IO JSAny-foreign import ccall __app3 :: JSFun -> JSAny -> JSAny -> JSAny -> IO JSAny-foreign import ccall __app4 :: JSFun- -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny-foreign import ccall __app5 :: JSFun- -> JSAny -> JSAny -> JSAny -> JSAny -> JSAny- -> IO JSAny-foreign import ccall __createJSFunc :: Int -> JSAny -> IO JSAny-#else-__strict :: JSAny -> JSAny-__strict x = x-__eval :: JSString -> JSFun-__eval _ = undefined-__apply :: JSFun -> Ptr [JSAny] -> IO JSAny-__apply _ _ = return undefined-__app0 :: JSFun -> IO JSAny-__app0 _ = return undefined-__app1 :: JSFun -> JSAny -> IO JSAny-__app1 _ _ = return undefined-__app2 :: JSFun -> JSAny -> JSAny -> IO JSAny-__app2 _ _ _ = return undefined-__app3 :: JSFun -> JSAny -> JSAny -> JSAny -> IO JSAny-__app3 _ _ _ _ = return undefined-__app4 :: JSFun -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny-__app4 _ _ _ _ _ = return undefined-__app5 :: JSFun -> JSAny -> JSAny -> JSAny -> JSAny -> JSAny -> IO JSAny-__app5 _ _ _ _ _ _ = return undefined-__createJSFunc :: Int -> JSAny -> IO JSAny-__createJSFunc _ = return undefined-#endif---- | Any type that can be imported from JavaScript. This means any type which--- has an instance of 'FromAny', and any function where all argument types--- has 'ToAny' instances and the return type is in the IO monad and has a--- 'FromAny' instance.-class FFI a where- __ffi :: JSFun -> [JSAny] -> a--instance FromAny a => FFI (IO a) where- {-# INLINE __ffi #-}- __ffi = ffiio--instance (ToAny a, FFI b) => FFI (a -> b) where- {-# INLINE __ffi #-}- __ffi f !as !a = __ffi f (a' : as)- where !a' = toAny a--{-# INLINE [0] ffiio #-}--- | Apply the result of an FFI call.-ffiio :: FromAny a => JSFun -> [JSAny] -> IO a-ffiio !f !as = __apply f (toPtr as) >>= fromAny--{-# INLINE ffi #-}--- | Creates a Haskell function from the given string of JavaScript code. If--- this code is not well typed or is otherwise incorrect, your program may--- crash or misbehave in mystifying ways. Haste makes a best-effort try to--- save you from poorly typed JS here, but there are no guarantees.------ For instance, the following WILL cause crazy behavior due to wrong types:------ > ffi "(function(x) {return x+1;})" :: Int -> Int -> IO Int------ In other words, this function is as unsafe as the JS it calls on. You--- have been warned.------ The imported JS is evaluated lazily, unless (a) it is a function object--- in which case evaluation order does not affect the semantics of the--- imported code, or if (b) the imported code is explicitly marked as strict:------ > someFunction = ffi "__strict(someJSFunction)"------ Literals which depends on some third party initialization, the existence--- of a DOM tree or some other condition which is not fulfilled at load time--- should *not* be marked strict.-ffi :: FFI a => JSString -> a-ffi s = __ffi f []- where- {-# NOINLINE f #-}- f = __eval s--#if __GLASGOW_HASKELL__ >= 710-safe_ffi :: FFI a => StaticPtr JSString -> a-safe_ffi = ffi . deRefStaticPtr-#endif---- | Create a Haskell value from a constant JS expression.-constant :: FromAny a => JSString -> a-constant = veryUnsafePerformIO . fromAny . __eval---- Don't build intermediate list for functions of <= 5 arguments.-{-# RULES-"app0" [1] forall f. ffiio f [] = __app0 f >>= fromAny-"app1" [1] forall f a. ffiio f [a] = __app1 f a >>= fromAny-"app2" [1] forall f a b. ffiio f [b,a] = __app2 f a b >>= fromAny-"app3" [1] forall f a b c. ffiio f [c,b,a] = __app3 f a b c >>= fromAny-"app4" [1] forall f a b c d. ffiio f [d,c,b,a] = __app4 f a b c d >>= fromAny-"app5" [1] forall f a b c d e. ffiio f [e,d,c,b,a] =- __app5 f a b c d e >>= fromAny- #-}---- | Export a symbol. That symbol may then be accessed from JavaScript through--- @Haste.name()@ as a normal function. Remember, however, that if you are--- using --with-js to include your JS, in conjunction with--- --opt-minify or any option that implies it, you will instead need--- to access your exports through @Haste[\'name\']()@, or Closure will mangle--- your function names.-{-# INLINE export #-}-export :: ToAny a => JSString -> a -> IO ()-export = ffi "(function(s,f){Haste[s] = f;})"--type family JS a where- JS (a -> b) = JSAny -> JS b- JS (IO a) = IO JSAny- JS a = JSAny--class JSFunc a where- mkJSFunc :: a -> JS a- arity :: a -> Int--#if __GLASGOW_HASKELL__ < 710-instance (ToAny a, JS a ~ JSAny) => JSFunc a where-#else-instance {-# OVERLAPPABLE #-} (ToAny a, JS a ~ JSAny) => JSFunc a where-#endif- mkJSFunc = toAny- arity _ = 0--{-# INLINE strictly #-}-strictly :: a -> a-strictly x = unsafeCoerce (__strict (unsafeCoerce x))--{-# RULES- "strictly" forall x. __strict x- = unsafeCoerce x- #-}--instance ToAny a => JSFunc (IO a) where- mkJSFunc = fmap toAny- arity _ = 1--instance (FromAny a, JSFunc b) => JSFunc (a -> b) where- mkJSFunc f = mkJSFunc . f . strictly . veryUnsafePerformIO . fromAny- arity f = 1 + arity (f undefined)--instance (FromAny a, JSFunc b) => ToAny (a -> b) where- toAny f =- strictly . veryUnsafePerformIO . __createJSFunc (arity f) . toAny . toOpaque $ mkJSFunc f--instance ToAny a => ToAny (IO a) where- toAny = strictly . veryUnsafePerformIO . __createJSFunc 0 . toAny . toOpaque . mkJSFunc--#if __GLASGOW_HASKELL__ < 710-instance FFI a => FromAny a where-#else-instance {-# OVERLAPPABLE #-} FFI a => FromAny a where-#endif- fromAny f = return $ __ffi f []---- | An exception raised from foreign JavaScript code.-data JSException = JSException JSString- deriving (Show, Typeable)--instance Exception JSException where-#if __GLASGOW_HASKELL__ >= 710- displayException (JSException e) = "JavaScript exception: " ++ fromJSStr e-#endif
− libraries/haste-prim/src/Haste/Prim/JSType.hs
@@ -1,287 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, ForeignFunctionInterface, MagicHash, - TypeSynonymInstances, FlexibleInstances, EmptyDataDecls,- UnliftedFFITypes, UndecidableInstances, CPP, OverloadedStrings #-}--- | Efficient conversions to and from JS native types.-module Haste.Prim.JSType (- JSType (..), JSNum (..), toString, fromString, convert- ) where-import GHC.Int-import GHC.Word-import Haste.Prim (JSString (..), toJSStr, fromJSStr)-#ifdef __HASTE__-import Haste.Prim (JSAny (..))-import GHC.Prim-import GHC.Integer.GMP.Internals-import GHC.Types (Int (..))-#else-import Data.Char-import GHC.Float-#endif---- | Any type which can be converted to/from a 'JSString'.-class JSType a where- toJSString :: a -> JSString- fromJSString :: JSString -> Maybe a---- | (Almost) all numeric types can be efficiently converted to and from--- Double, which is the internal representation for most of them.-class JSNum a where- toNumber :: a -> Double- fromNumber :: Double -> a--instance JSType JSString where- toJSString = id- fromJSString = Just--#ifdef __HASTE__--foreign import ccall "Number" jsNumber :: JSString -> Double-foreign import ccall "String" jsString :: Double -> JSString-foreign import ccall jsTrunc :: Double -> Int-foreign import ccall "I_toInt" jsIToInt :: ByteArray# -> Int-foreign import ccall "I_toString" jsIToString :: ByteArray# -> JSString-foreign import ccall "I_fromString" jsStringToI :: JSString -> ByteArray#-foreign import ccall "I_fromNumber" jsNumToI :: ByteArray# -> ByteArray#--unsafeToJSString :: a -> JSString-unsafeToJSString = unsafeCoerce# jsString--unsafeIntFromJSString :: JSString -> Maybe Int-unsafeIntFromJSString s =- case jsNumber s of- d | isNaN d -> Nothing- | otherwise -> Just (unsafeCoerce# (jsTrunc d))----- JSNum instances--instance JSNum Char where- fromNumber = unsafeCoerce# jsTrunc- toNumber = unsafeCoerce#--instance JSNum Int where- fromNumber = unsafeCoerce# jsTrunc- toNumber = unsafeCoerce#--instance JSNum Int8 where- fromNumber n = case fromNumber n of I# n' -> I8# (narrow8Int# n')- toNumber = unsafeCoerce#--instance JSNum Int16 where- fromNumber n = case fromNumber n of I# n' -> I16# (narrow16Int# n')- toNumber = unsafeCoerce#--instance JSNum Int32 where- fromNumber = unsafeCoerce# jsTrunc- toNumber = unsafeCoerce#--instance JSNum Word where- fromNumber n =- case jsTrunc (unsafeCoerce# n) of- I# n' -> W# (int2Word# n')- toNumber = unsafeCoerce#--instance JSNum Word8 where- fromNumber w = case fromNumber w of W# w' -> W8# (narrow8Word# w')- toNumber = unsafeCoerce#--instance JSNum Word16 where- fromNumber w = case fromNumber w of W# w' -> W16# (narrow16Word# w')- toNumber = unsafeCoerce#--instance JSNum Word32 where- fromNumber w = case fromNumber w of W# w' -> W32# w'- toNumber = unsafeCoerce#--instance JSNum Integer where- toNumber (S# n) = toNumber (I# n)- toNumber (J# n) = unsafeCoerce# (jsIToInt n)- fromNumber n = J# (jsNumToI (unsafeCoerce# n))--instance JSNum Float where- fromNumber = unsafeCoerce#- toNumber = unsafeCoerce#--instance JSNum Double where- fromNumber = id- toNumber = id---- JSType instances-instance JSType Bool where- toJSString True = "true"- toJSString _ = "false"- fromJSString "true" = Just True- fromJSString "false" = Just False- fromJSString _ = Nothing-instance JSType Int where- toJSString = unsafeToJSString- fromJSString = unsafeIntFromJSString-instance JSType Int8 where- toJSString = unsafeToJSString- fromJSString = fmap fromIntegral . unsafeIntFromJSString-instance JSType Int16 where- toJSString = unsafeToJSString- fromJSString = fmap fromIntegral . unsafeIntFromJSString-instance JSType Int32 where- toJSString = unsafeToJSString- fromJSString = unsafeCoerce# unsafeIntFromJSString-instance JSType Word where- toJSString = unsafeToJSString- fromJSString = fmap fromIntegral . unsafeIntFromJSString-instance JSType Word8 where- toJSString = unsafeToJSString- fromJSString = fmap fromIntegral . unsafeIntFromJSString-instance JSType Word16 where- toJSString = unsafeToJSString- fromJSString = fmap fromIntegral . unsafeIntFromJSString-instance JSType Word32 where- toJSString = unsafeToJSString- fromJSString = fmap fromIntegral . unsafeIntFromJSString--instance JSType Float where- fromJSString s =- case jsNumber s of- d | isNaN d -> Nothing- | otherwise -> Just (unsafeCoerce# d)- toJSString = unsafeToJSString--instance JSType Double where- fromJSString s =- case jsNumber s of- d | isNaN d -> Nothing- | otherwise -> Just d- toJSString = unsafeToJSString---- This is completely insane, but GHC for some reason pukes when we try to--- use the constructors of the actual integers, so we coerce them into this--- isomorphic type to work with them instead.-data Dummy = Small Int# | Big ByteArray#--instance JSType Integer where- toJSString n =- case unsafeCoerce# n of- Small n' -> toJSString (I# n')- Big n' -> jsIToString n'- fromJSString s =- case jsStringToI s of- n -> Just (unsafeCoerce# (Big n))--instance JSType String where- toJSString = toJSStr- fromJSString = Just . fromJSStr--instance JSType () where- toJSString _ = toJSStr "()"- fromJSString s | s == toJSStr "()" = Just ()- | otherwise = Nothing--#else--instance JSNum Char where- toNumber = fromIntegral . ord- fromNumber = chr . round--instance JSNum Int where- toNumber = fromIntegral- fromNumber = round-instance JSNum Int8 where- toNumber = fromIntegral- fromNumber = round-instance JSNum Int16 where- toNumber = fromIntegral- fromNumber = round-instance JSNum Int32 where- toNumber = fromIntegral- fromNumber = round--instance JSNum Word where- toNumber = fromIntegral- fromNumber = round-instance JSNum Word8 where- toNumber = fromIntegral- fromNumber = round-instance JSNum Word16 where- toNumber = fromIntegral- fromNumber = round-instance JSNum Word32 where- toNumber = fromIntegral- fromNumber = round--instance JSNum Double where- toNumber = id- fromNumber = id-instance JSNum Float where- toNumber = float2Double- fromNumber = double2Float--instance JSNum Integer where- toNumber = fromInteger- fromNumber = round--mread :: Read a => String -> Maybe a-mread s =- case reads s of- [(x, "")] -> x- _ -> Nothing--instance JSType Int where- toJSString = toJSStr . show- fromJSString = mread . fromJSStr-instance JSType Int8 where- toJSString = toJSStr . show- fromJSString = mread . fromJSStr-instance JSType Int16 where- toJSString = toJSStr . show- fromJSString = mread . fromJSStr-instance JSType Int32 where- toJSString = toJSStr . show- fromJSString = mread . fromJSStr--instance JSType Word where- toJSString = toJSStr . show- fromJSString = mread . fromJSStr-instance JSType Word8 where- toJSString = toJSStr . show- fromJSString = mread . fromJSStr-instance JSType Word16 where- toJSString = toJSStr . show- fromJSString = mread . fromJSStr-instance JSType Word32 where- toJSString = toJSStr . show- fromJSString = mread . fromJSStr--instance JSType Double where- toJSString = toJSStr . show- fromJSString = mread . fromJSStr-instance JSType Float where- toJSString = toJSStr . show- fromJSString = mread . fromJSStr--instance JSType Integer where- toJSString = toJSStr . show- fromJSString = mread . fromJSStr--instance JSType Bool where- toJSString = toJSStr . show- fromJSString = mread . fromJSStr--instance JSType () where- toJSString = toJSStr . show- fromJSString = mread . fromJSStr--instance JSType String where- toJSString = toJSStr- fromJSString = Just . fromJSStr--#endif---- Derived functions--toString :: JSType a => a -> String-toString = fromJSStr . toJSString--fromString :: JSType a => String -> Maybe a-fromString = fromJSString . toJSStr--convert :: (JSNum a, JSNum b) => a -> b-convert = fromNumber . toNumber
src/Haste/AST/Binary.hs view
@@ -9,9 +9,9 @@ import Haste.AST.Op instance Binary Module where- put (Module pkgid name deps defs) =- put pkgid >> put name >> put deps >> put defs- get = Module <$> get <*> get <*> get <*> get+ put (Module pkgid name deps spt defs) =+ put pkgid >> put name >> put deps >> put spt >> put defs+ get = Module <$> get <*> get <*> get <*> get <*> get instance Binary Var where put (Foreign str) =
src/Haste/AST/Constructors.hs view
@@ -1,7 +1,4 @@ {-# LANGUAGE FlexibleInstances, TupleSections, CPP, OverloadedStrings #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif -- | Smart constructors for Haste's AST. module Haste.AST.Constructors where import Haste.AST.Syntax@@ -31,11 +28,7 @@ instance Literal [Char] where lit = lit . BS.fromString -#if __GLASGOW_HASKELL__ < 710-instance Literal a => Literal [a] where-#else instance {-# OVERLAPPABLE #-} Literal a => Literal [a] where-#endif lit = Arr . map lit instance Literal Exp where
src/Haste/AST/Optimize.hs view
@@ -37,7 +37,7 @@ optimizeFun c f ast = runTravM $ do shrinkCase ast- >>= inlineAssigns+ >>= inlineAssigns [] >>= optimizeArrays >>= inlineReturns >>= zapJSStringConversions@@ -51,13 +51,13 @@ >>= optWhen (inlineJSPrim c) inlineJSPrimitives >>= mapJS (const True) pure (pure . removeNonsenseAssigns) -topLevelInline :: Config -> Stm -> Stm-topLevelInline c ast =+topLevelInline :: Config -> [Name] -> Stm -> Stm+topLevelInline c spt ast = runTravM $ do pure ast >>= unevalLits >>= inlineIntoEval- >>= inlineAssigns+ >>= inlineAssigns spt' >>= optimizeArrays >>= optimizeThunks >>= smallStepInline@@ -65,13 +65,15 @@ >>= zapJSStringConversions >>= optWhen (inlineJSPrim c) inlineJSPrimitives >>= removeUselessEvals- >>= inlineAssigns+ >>= inlineAssigns spt' >>= smallStepInline- >>= inlineAssigns+ >>= inlineAssigns spt' >>= optWhen (detrampolineThreshold c > 0) (unTrampoline $ detrampolineThreshold c) >>= inlineLiteralFunCalls >>= optWhen (flowAnalysisOpts c) flowOpts+ where+ spt' = map (\n -> Internal n "" False) spt -- | Attempt to turn two case branches into a ternary operator expression.@@ -92,8 +94,8 @@ -- Make sure the return expression is used somewhere, then cut away all -- useless assignments. If what's left is a single Return statement, -- we have a pure expression suitable for use with ?:.- def'' <- inlineAssigns def'- alt'' <- inlineAssigns alt'+ def'' <- inlineAssigns [] def'+ alt'' <- inlineAssigns [] alt' -- If self occurs in either branch, we can't inline or we risk ruining -- tail call elimination. selfInDef <- occurrences (const True) selfOccurs def''@@ -130,17 +132,22 @@ -- | Inline assignments where the assignee is only ever used once. -- Does not inline anything into a shared code path, as that would break--- things horribly.+-- things horribly. Also doesn't inline anything from the SPT.+-- The SPT is only necessary when performing top-level inlining. For anything+-- else an empty list should be used, as any SPT entries are inevitably going.+-- to be free vars and thus not inlineable.+-- -- Ignores LhsExp assignments, since we only introduce those when we actually -- care about the assignment side effect.-inlineAssigns :: JSTrav ast => ast -> TravM ast-inlineAssigns ast = do+inlineAssigns :: JSTrav ast => [Var] -> ast -> TravM ast+inlineAssigns spt ast = do inlinable <- countVarOccs ast mapJS (const True) return (inl inlinable) ast where -- Assume that an assignment that is never used is actually there for a -- good reason and thus not inlinable. isSafe i v+ | v `elem` spt = False | Just Once <- M.lookup v i = True | otherwise = False
src/Haste/AST/PP.hs view
@@ -81,20 +81,29 @@ case runPP cfg (pp ast) of (b, _) -> toLazyByteString b --- | Run a pretty printer.-runPP :: Config -> PP a -> (Builder, a)-runPP cfg p =- case unPP p cfg 0 emptyNS mempty of+-- | Run a pretty printer with the given name supply.+runPPWith :: Config -> NameSupply -> PP a -> (Builder, a)+runPPWith cfg ns p =+ case unPP p cfg 0 ns mempty of (_, b, x) -> (b, x) --- | Pretty-print a program and return the final name for its entry point.-prettyProg :: Pretty a => Config -> Name -> a -> (Builder, Builder)-prettyProg cfg mainSym ast = runPP cfg $ do+-- | Run a pretty printer with an empty name supply.+runPP :: Config -> PP a -> (Builder, a)+runPP cfg = runPPWith cfg emptyNS++-- | Takes a config, a program entry point, and a pretty-printable program.+-- Returns the pretty-printed program, the final names for all static+-- pointers in the program, and the final name of the main symbol, in that+-- order.+prettyProg :: Pretty a => Config -> Name -> [Name] -> a -> (Builder, ([Builder], Builder))+prettyProg cfg mainSym spt ast = runPP cfg $ do pp ast hsnames <- getOpt preserveNames- if hsnames- then return $ buildStgName mainSym- else buildFinalName <$> finalNameFor mainSym+ main <- if hsnames+ then return $ buildStgName mainSym+ else buildFinalName <$> finalNameFor mainSym+ spt' <- mapM (fmap buildFinalName . finalNameFor) spt+ return (spt', main) -- | JS-mangled version of an internal name. buildStgName :: Name -> Builder
src/Haste/AST/Print.hs view
@@ -42,8 +42,9 @@ pp (LhsExp _ ex) = pp ex instance Pretty Lit where- pp (LNum d) = put d- pp (LStr s) = "\"" .+. put (fixQuotes $ BS.toString s) .+. "\""+ pp (LNum d) | d >= 0 = put d+ pp (LNum d) | otherwise = " " .+. put d+ pp (LStr s) = "\"" .+. put (fixQuotes $ BS.toString s) .+. "\"" where fixQuotes ('\\':xs) = "\\\\" ++ fixQuotes xs fixQuotes ('"':xs) = '\\':'"' : fixQuotes xs
src/Haste/AST/Syntax.hs view
@@ -3,11 +3,7 @@ -- | Abstract syntax of Haste's intermediate format. module Haste.AST.Syntax where import qualified Data.Set as S-#if __GLASGOW_HASKELL__ >= 708 import qualified Data.Map.Strict as M-#else-import qualified Data.Map as M-#endif import Haste.AST.Op import qualified Data.ByteString.Char8 as BS @@ -154,7 +150,8 @@ modPackageId :: !BS.ByteString, modName :: !BS.ByteString, modDeps :: M.Map Name (S.Set Name),- modDefs :: M.Map Name Exp+ modDefs :: M.Map Name Exp,+ modSPT :: [Name] } -- | Merge two modules. The module and package IDs of the second argument are@@ -165,7 +162,8 @@ modPackageId = modPackageId m2, modName = modName m2, modDeps = M.union (modDeps m1) (modDeps m2),- modDefs = M.union (modDefs m1) (modDefs m2)+ modDefs = M.union (modDefs m1) (modDefs m2),+ modSPT = modSPT m1 ++ modSPT m2 } -- | Imaginary module for foreign code that may need one.@@ -174,7 +172,8 @@ modPackageId = "", modName = "", modDeps = M.empty,- modDefs = M.empty+ modDefs = M.empty,+ modSPT = [] } -- | An LHS that's guaranteed to not ever be read, enabling the pretty
src/Haste/CodeGen.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE TupleSections, PatternGuards, CPP, OverloadedStrings #-} module Haste.CodeGen (generate) where -- Misc. stuff-import Control.Applicative import Control.Monad import Data.Int import Data.Bits@@ -17,6 +16,7 @@ -- STG/GHC stuff import Language.Haskell.GHC.Simple as GHC import FastString (unpackFS)+import PrelNames (staticPtrTyConKey) -- AST stuff import Haste.AST as AST hiding ((.&.))@@ -36,25 +36,26 @@ modPackageId = BS.fromString $ GHC.mmPackageKey meta, AST.modName = BS.fromString $ GHC.mmName meta, modDeps = foldl' insDep M.empty theMod,- modDefs = foldl' insFun M.empty theMod+ modDefs = foldl' insFun M.empty theMod,+ modSPT = concat [spt | (_, spt, _) <- theMod] } where opt = if optimize cfg then optimizeFun cfg else const id theMod = genAST cfg (GHC.mmName meta) stg - insFun m (_, Assign (NewVar _ v@(Internal n _ _)) body _) =+ insFun m (_, _, Assign (NewVar _ v@(Internal n _ _)) body _) = M.insert n (opt v body) m insFun m _ = m -- TODO: perhaps do dependency-based linking for externals as well?- insDep m (ds, Assign (NewVar _ (Internal v _ _)) _ _) =+ insDep m (ds, _, Assign (NewVar _ (Internal v _ _)) _ _) = M.insert v (S.delete v ds) m insDep m _ = m -- | Generate JS AST for bindings.-genAST :: Config -> String -> [StgBinding] -> [(S.Set AST.Name, Stm)]+genAST :: Config -> String -> [StgBinding] -> [(S.Set Dep, [StaticPtr], Stm)] genAST cfg modname binds = binds' where@@ -62,7 +63,7 @@ map (depsAndCode . genJS cfg modname . uncurry (genBind True)) $ concatMap unRec $ binds- depsAndCode (_, ds, locs, stm) = (ds S.\\ locs, stm stop)+ depsAndCode (_, ds, locs, spt, stm) = (ds S.\\ locs, spt, stm stop) -- | Check for builtins that should generate inlined code. At this point only -- w2i and i2w.@@ -153,15 +154,7 @@ genEx ex genEx (StgCase ex _ _ bndr _ t alts) = do genCase t ex bndr alts- -#if __GLASGOW_HASKELL__ < 710--- StgSCC is gone in 7.10, and StgTick has an argument less.-genEx (StgSCC _ _ _ ex) = do- genEx ex-genEx (StgTick _ _ ex) = do-#else genEx (StgTick _ ex) = do-#endif genEx ex genEx (StgLam _ _) = do@@ -192,8 +185,9 @@ genBind onTopLevel funsInRecGroup (StgNonRec v rhs) = do v' <- genVar v pushBind v'- when (not onTopLevel) $ do- addLocal v'+ if onTopLevel+ then when (isStaticPtr v) $ addStaticPtr v'+ else addLocal v' expr <- genRhs isRecursive rhs popBind continue $ newVar (not isRecursive) v' expr@@ -531,6 +525,13 @@ [t] -> return (isUnLiftedType t) _ -> return False _ -> return False++-- | Is the given var a static pointer?+isStaticPtr :: GHC.Var -> Bool+isStaticPtr v =+ case splitTyConApp_maybe (varType v) of+ Just (tycon, _) -> tyConUnique tycon == staticPtrTyConKey+ _ -> False -- | Returns True if the given Var is an unboxed tuple with a single element -- after any represenationless elements are discarded.
src/Haste/Config.hs view
@@ -20,7 +20,7 @@ "rts.js", "floatdecode.js", "stdlib.js", "endian.js", "bn.js", "MVar.js", "StableName.js", "Integer.js", "long.js", "md5.js", "array.js", "pointers.js", "cheap-unicode.js", "Handle.js", "Weak.js",- "Foreign.js"+ "Foreign.js", "spt.js" ] debugLib :: FilePath
src/Haste/Environment.hs view
@@ -10,9 +10,6 @@ closureCompiler, bootFile, portableHaste, hasteNeedsReboot ) where-#if __GLASGOW_HASKELL__ <= 708-import Control.Applicative-#endif import Control.Shell import Data.Bits import Foreign.C.Types (CIntPtr)@@ -112,11 +109,7 @@ -- | Host word size in bits. hostWordSize :: Int-#if __GLASGOW_HASKELL__ >= 708 hostWordSize = finiteBitSize (undefined :: CIntPtr)-#else-hostWordSize = bitSize (undefined :: CIntPtr)-#endif -- | File extension of binaries on this system. binaryExt :: String
src/Haste/Linker.hs view
@@ -13,17 +13,15 @@ import Data.ByteString.UTF8 (toString, fromString) import Data.ByteString.Builder import Data.Monoid+import Data.List (sort, group) import System.IO (hPutStrLn, stderr)+import Crypto.Hash -- | The program entry point. -- This will need to change when we start supporting building "binaries" -- using cabal, since we'll have all sorts of funny package names then. mainSym :: Name-#if __GLASGOW_HASKELL__ < 709-mainSym = name "main" (Just ("main", ":Main"))-#else mainSym = name "main" (Just ("main", "Main"))-#endif -- | Link a program using the given config and input file name. link :: Config -> BS.ByteString -> FilePath -> IO ()@@ -32,38 +30,61 @@ case mainMod cfg of Just (m, p) -> (fromString m, fromString p) _ -> error "Haste.Linker.link called without main sym!"- ds <- getAllDefs cfg (targetLibPath cfg : libPaths cfg) mainmod pkgid mainSym+ (spt, ds) <- getAllDefs cfg (targetLibPath cfg : libPaths cfg) mainmod pkgid mainSym let myDefs = if wholeProgramOpts cfg- then topLevelInline cfg ds+ then topLevelInline cfg spt ds else ds- (progText, myMain') = prettyProg cfg mainSym myDefs+ (progText, (spt', myMain')) = prettyProg cfg mainSym spt myDefs callMain = stringUtf8 "B(A(" <> myMain' <> stringUtf8 ", [0]));" launchApp = appStart cfg (stringUtf8 "hasteMain") rtslibs <- mapM readFile $ rtsLibs cfg extlibs <- mapM readFile $ jsExternals cfg- B.writeFile (outFile cfg cfg target)- $ toLazyByteString- $ assembleProg (wrapProg cfg) extlibs rtslibs progText callMain launchApp+ let finalProgram = toLazyByteString $ assembleProg (wrapProg cfg)+ extlibs+ rtslibs+ progText+ callMain+ launchApp+ spt'+ B.writeFile (outFile cfg cfg target) finalProgram where- assembleProg True extlibs rtslibs progText callMain launchApp =+ addHashLine p = concat+ [ "var __haste_prog_id = '"+ , show (hash (B.toStrict p) :: Digest SHA3_256)+ , "';\n"+ ]+ assembleProg True extlibs rtslibs progText callMain launchApp spt = stringUtf8 (unlines extlibs)- <> stringUtf8 "var hasteMain = function() {"- <> (if useStrict cfg then stringUtf8 "\n\"use strict\";\n" else mempty)+ <> stringUtf8 "function hasteMain() {\n"+ <> (if useStrict cfg then stringUtf8 "\"use strict\";\n" else mempty)+ <> stringUtf8 (addHashLine (toLazyByteString progText))+ <> stringUtf8 "var __haste_script_elem = hasteMain.scriptElem;\n" <> stringUtf8 (unlines rtslibs) <> progText+ <> mconcat (map addSPT spt) <> callMain <> stringUtf8 "};\n"+ <> stringUtf8 "hasteMain.scriptElem = typeof document == 'object' ? document.currentScript : null;\n" <> launchApp- assembleProg _ extlibs rtslibs progText callMain launchApp =+ assembleProg _ extlibs rtslibs progText callMain launchApp spt = (if useStrict cfg then stringUtf8 "\"use strict\";\n" else mempty)+ <> stringUtf8 (addHashLine (toLazyByteString progText))+ <> stringUtf8 "var __haste_script_elem = typeof document == 'object' ? document.currentScript : null;\n" <> stringUtf8 (unlines extlibs) <> stringUtf8 (unlines rtslibs) <> progText+ <> mconcat (map addSPT spt) <> stringUtf8 "\nvar hasteMain = function() {" <> callMain <> stringUtf8 "};" <> launchApp + addSPT ptr = mconcat+ [ stringUtf8 "__spt_insert("+ , ptr+ , stringUtf8 ");\n"+ ]+ -- | Produce an info message if verbose reporting is enabled. info' :: Config -> String -> IO () info' cfg = when (verbose cfg) . hPutStrLn stderr@@ -74,7 +95,7 @@ -> (BS.ByteString, BS.ByteString) -> BS.ByteString -> Name- -> IO Stm+ -> IO ([Name], Stm) getAllDefs cfg libpaths mainmod pkgid mainsym = runDep cfg mainmod $ addDef libpaths pkgid mainsym @@ -83,7 +104,8 @@ defs :: !(Stm -> Stm), alreadySeen :: !(S.Set Name), modules :: !(M.Map BS.ByteString Module),- infoLogger :: String -> IO ()+ infoLogger :: String -> IO (),+ staticPtrs :: ![[Name]] } type DepM a = EitherT Name (StateT DepState IO) a@@ -94,7 +116,8 @@ defs = id, alreadySeen = S.empty, modules = M.empty,- infoLogger = info' cfg+ infoLogger = info' cfg,+ staticPtrs = [] } -- | Log a message to stdout if verbose reporting is on.@@ -104,12 +127,12 @@ liftIO $ infoLogger st s -- | Run a dependency resolution computation.-runDep :: Show a => Config -> (BS.ByteString,BS.ByteString) -> DepM a -> IO Stm+runDep :: Show a => Config -> (BS.ByteString,BS.ByteString) -> DepM a -> IO ([Name], Stm) runDep cfg mainmod m = do res <- runStateT (runEitherT m) (initState cfg mainmod) case res of (Right _, st) ->- return $ defs st stop+ return (snubcat $ staticPtrs st, defs st stop) (Left (Name f (Just (_, modul))), _) -> do error $ msg (toString modul) (toString f) (r, _) -> do@@ -125,6 +148,9 @@ msg s f = "Unable to locate function `" ++ f ++ "' in module `" ++ s ++ "'!" + -- snubcat: sort + nub + concat in O(n log n) instead of O(n²)+ snubcat = map head . group . sort . concat+ -- | Return the module the given variable resides in. getModuleOf :: [FilePath] -> Name -> DepM Module getModuleOf libpaths v@(Name n _) =@@ -158,7 +184,11 @@ case mm of Just m -> do st <- get- put st {modules = M.insert modname m (modules st)}+ put st+ { modules = M.insert modname m (modules st)+ , staticPtrs = modSPT m : staticPtrs st+ }+ mapM_ (addDef libpaths pkgid) (modSPT m) return (Just m) _ -> do go lps
src/Haste/Module.hs view
@@ -4,7 +4,6 @@ import Module (moduleNameSlashes, mkModuleName) import qualified Data.ByteString.Lazy as B import Control.Shell-import Control.Applicative import Haste.AST import Data.Binary import Data.List (isSuffixOf)@@ -34,7 +33,7 @@ -- -- Boot modules and "normal" modules get merged at this stage. writeModule :: FilePath -> Module -> Bool -> IO ()-writeModule basepath m@(Module _ modname _ _) boot =+writeModule basepath m@(Module _ modname _ _ _) boot = fromRight "writeModule" . shell $ do mkdir True (takeDirectory path) mcompanion <- readMod basepath modstr (not boot)@@ -85,9 +84,6 @@ _ -> do return stdname | otherwise = do-#if __GLASGOW_HASKELL__ < 709- return stdname-#else mfile <- findLibFile [basepath] case mfile of Just f -> do@@ -101,7 +97,6 @@ case dirs' of ds | not (null ds) -> maybe stdname id <$> findLibFile ds | otherwise -> return stdname-#endif where findLibFile (d:ds) = do fs <- map (d </>) . filter (libfilesuffix `isSuffixOf`) <$> ls d
src/Haste/Monad.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses #-} module Haste.Monad (- JSGen, genJS, dependOn, getModName, addLocal, getCfg, continue, isolate,- pushBind, popBind, getCurrentBinding, whenCfg, rename, getActualName+ JSGen, LocalSymbol, Dep, StaticPtr,+ genJS, dependOn, addLocal, addStaticPtr, getModName, getCfg, continue,+ isolate, pushBind, popBind, getCurrentBinding, whenCfg, rename,+ getActualName ) where import Control.Monad.State.Strict import Haste.AST as AST hiding (modName)@@ -10,11 +12,17 @@ import Control.Applicative import qualified Data.Map as M +type LocalSymbol = Name+type Dep = Name+type StaticPtr = Name+ data GenState cfg = GenState { -- | Dependencies in current context. deps :: ![Name], -- | Local variables in current context. locals :: ![Name],+ -- | Static pointers encountered so far.+ staticPtrs :: ![Name], -- | The current continuation. Code is generated by appending to this -- continuation. continuation :: !(Stm -> Stm),@@ -32,6 +40,7 @@ initialState cfg = GenState { deps = [], locals = [],+ staticPtrs = [], continuation = id, bindStack = [], modName = "",@@ -48,6 +57,8 @@ dependOn :: a -> JSGen cfg () -- | Mark a symbol as local, excluding it from the dependency graph. addLocal :: a -> JSGen cfg ()+ -- | Add a symbol to the list of static pointers encountered so far.+ addStaticPtr :: a -> JSGen cfg () instance Dependency AST.Name where {-# INLINE dependOn #-}@@ -60,6 +71,9 @@ st <- get put st {locals = v : locals st} + {-# INLINE addStaticPtr #-}+ addStaticPtr v = JSGen $ modify $ \st -> st {staticPtrs = v : staticPtrs st}+ instance Dependency AST.Var where {-# INLINE dependOn #-} dependOn (Foreign _) = return ()@@ -69,22 +83,27 @@ addLocal (Foreign _) = return () addLocal (Internal n _ _) = addLocal n + addStaticPtr (Foreign _) = return ()+ addStaticPtr (Internal n _ _) = addStaticPtr n+ instance Dependency a => Dependency [a] where- dependOn = mapM_ dependOn- addLocal = mapM_ addLocal+ dependOn = mapM_ dependOn+ addLocal = mapM_ addLocal+ addStaticPtr = mapM_ addStaticPtr instance Dependency a => Dependency (S.Set a) where- dependOn = dependOn . S.toList- addLocal = addLocal . S.toList+ dependOn = dependOn . S.toList+ addLocal = addLocal . S.toList+ addStaticPtr = addStaticPtr . S.toList genJS :: cfg -- ^ Config to use for code generation. -> String -- ^ Name of the module being compiled. -> JSGen cfg a -- ^ The code generation computation.- -> (a, S.Set AST.Name, S.Set AST.Name, Stm -> Stm)+ -> (a, S.Set Dep, S.Set LocalSymbol, [StaticPtr], Stm -> Stm) genJS cfg myModName (JSGen gen) = case runState gen (initialState cfg) {modName = myModName} of- (a, GenState dependencies loc cont _ _ _ _) ->- (a, S.fromList dependencies, S.fromList loc, cont)+ (a, GenState dependencies loc spt cont _ _ _ _) ->+ (a, S.fromList dependencies, S.fromList loc, spt, cont) getModName :: JSGen cfg String getModName = JSGen $ modName <$> get@@ -118,7 +137,7 @@ cfg <- getCfg b <- getCurrentBinding rns <- renames <$> JSGen get- let (x, dep, loc, cont) = genJS cfg myMod $ do+ let (x, dep, loc, spt, cont) = genJS cfg myMod $ do pushBind b JSGen $ do st <- get@@ -126,6 +145,7 @@ gen dependOn dep addLocal loc+ addStaticPtr spt return (x, cont) getCfg :: JSGen cfg cfg
src/Haste/PrimOps.hs view
@@ -276,6 +276,7 @@ Right $ index x (litS "off") where (x:_) = xs+ AddrToAnyOp -> Right $ head xs -- MVars NewMVarOp -> callF "newMVar"@@ -315,7 +316,6 @@ PopCnt32Op -> Right $ callForeign "popCnt" [head xs] PopCnt64Op -> Right $ callForeign "popCnt64" [head xs] -#if __GLASGOW_HASKELL__ >= 710 ClzOp -> Right $ callForeign "__clz" [litN 32, head xs] Clz8Op -> Right $ callForeign "__clz" [litN 8, head xs] Clz16Op -> Right $ callForeign "__clz" [litN 16, head xs]@@ -325,7 +325,6 @@ Ctz8Op -> Right $ callForeign "__ctz" [litN 8, head xs] Ctz16Op -> Right $ callForeign "__ctz" [litN 16, head xs] Ctz32Op -> Right $ callForeign "__ctz" [litN 32, head xs] -#endif -- Concurrency - only relevant in a threaded environment NoDuplicateOp -> Right $ defState
src/haste-boot.hs view
@@ -19,18 +19,17 @@ import System.Info (os) import System.Directory (copyPermissions) -#if __GLASGOW_HASKELL__ >= 710+#if __GLASGOW_HASKELL__ < 800 ghcMajor = "7.10" libDir = "ghc-7.10" primVersion = "0.4.0.0"-#else-ghcMajor = "7.8"-libDir = "ghc-7.8"-primVersion = "0.3.0.0" #endif -data HasteCabal = Download | Prebuilt FilePath | Source (Maybe FilePath)+logStr :: String -> Shell ()+logStr s = echo $ "[haste-boot] " ++ s +data HasteCabal = Download | Prebuilt FilePath | Source (Maybe FilePath) | Preinstalled+ data Cfg = Cfg { getLibs :: Bool, getClosure :: Bool,@@ -103,7 +102,6 @@ "Prepare boot files for binary distribution. Should only ever " ++ "be called by the release build scripts, never by users.\n" ++ "Implies --local --force."-#ifndef PORTABLE , Option "" ["local"] (NoArg $ \cfg -> cfg {useLocalLibs = True}) $ "Use libraries from source repository rather than " ++@@ -121,9 +119,13 @@ (NoArg $ \cfg -> cfg {getHasteCabal = Download}) $ "Download pre-built haste-cabal for your platform. " ++ "This is the default behaviour."+ , Option "" ["no-haste-cabal"]+ (NoArg $ \cfg -> cfg {getHasteCabal = Preinstalled}) $+ "Use whatever haste-cabal is found on your path; it will not be copied." , Option "" ["with-haste-cabal"] (ReqArg (\f cfg -> cfg {getHasteCabal = Prebuilt f}) "FILE") $- "Use FILE to provide haste-cabal."+ "Use FILE to provide haste-cabal. It will be copied into the " +++ "Haste binary directory." , Option "" ["build-haste-cabal"] (OptArg (\md cfg -> cfg {getHasteCabal = Source md}) "DIR") $ "Build haste-cabal from the source contained in DIR. " ++@@ -137,7 +139,6 @@ "Build standard libs for tracing of primitive " ++ "operations. Only use if you're debugging the code " ++ "generator."-#endif , Option "v" ["verbose"] (NoArg $ \cfg -> cfg {verbose = True}) $ "Print absolutely everything."@@ -146,7 +147,7 @@ hdr :: String hdr = "Fetch, build and install all libraries necessary to use Haste.\n" -data CabalOp = Configure | Build | Install | Clean | Do String+data CabalOp = Configure | Build | Install | Clean main :: IO () main = shell_ $ do@@ -160,53 +161,62 @@ when (hasteNeedsReboot || forceBoot cfg) $ do if useLocalLibs cfg then bootHaste cfg "."- else withTempDirectory "haste" $ bootHaste cfg+ else withTempDirectory $ bootHaste cfg (cfgs, nopts, errs) -> do let errors = errs ++ map (\x -> "unrecognized option `" ++ x ++ "'") nopts fail $ unlines errors bootHaste :: Cfg -> FilePath -> Shell () bootHaste cfg tmpdir =- withEnv "nodosfilewarning" (const "1") . inDirectory tmpdir $ do+ withEnv "nodosfilewarning" "1" . inDirectory tmpdir $ do removeBootFile <- isFile bootFile when removeBootFile $ rm bootFile when (getLibs cfg) $ do -- Don't clear dir when it contains binaries; portable should only be built -- by scripts anyway, so this dir ought to be clean. when (not portableHaste) $ do+ logStr "Removing old library directories" mapM_ clearDir [pkgUserLibDir, jsmodUserDir, pkgUserDir, pkgSysLibDir, jsmodSysDir, pkgSysDir] mkdir True (hasteCabalRootDir portableHaste) case getHasteCabal cfg of- Download -> installHasteCabal portableHaste tmpdir- Prebuilt fp -> copyHasteCabal portableHaste fp- Source mdir -> buildHasteCabal portableHaste (maybe "../cabal" id mdir)+ Download -> installHasteCabal portableHaste tmpdir+ Prebuilt fp -> copyHasteCabal portableHaste fp+ Source mdir -> buildHasteCabal portableHaste (maybe "../cabal" id mdir)+ Preinstalled -> return () -- Spawn off closure download in the background. dir <- pwd -- use absolute path for closure to avoid dir changing race closure <- future $ when (getClosure cfg) (installClosure dir) + -- Do a haste-cabal update before trying anything cabal related+ run hasteCabalBinary ["update"]+ when (not $ useLocalLibs cfg) $ do fetchLibs tmpdir when (not portableHaste || initialPortableBoot cfg) $ do+ logStr "Installing GHC settings" mkdir True hasteSysDir copyGhcSettings hasteSysDir- void $ run hastePkgBinary ["init", pkgSysDir] ""+ run hastePkgBinary ["init", pkgSysDir] buildLibs cfg when (initialPortableBoot cfg) $ do+ logStr "Relocating libraries" mapM_ relocate ["array", "bytestring", "containers", "base",- "deepseq", "haste-prim", "time", "haste-lib",+ "deepseq", "dlist", "haste-prim", "time", "haste-lib", "monads-tf", "old-locale", "transformers", "integer-gmp",- "hashable", "text", "binary", "random", "QuickCheck", "text"]+ "hashable", "text", "binary"] -- Wait for closure download to finish. await closure + logStr "Creating boot file" output bootFile (showBootVersion bootVersion)+ logStr "All done!" clearDir :: FilePath -> Shell () clearDir dir = do@@ -225,7 +235,7 @@ buildHasteCabal :: Bool -> FilePath -> Shell () buildHasteCabal portable dir = do- inDirectory dir $ run_ "runghc" ["build-haste-cabal.hs"] ""+ inDirectory dir $ run "runghc" ["build-haste-cabal.hs"] copyHasteCabal portable (dir </> "haste-cabal" </> "haste-cabal.bin") installHasteCabal :: Bool -> FilePath -> Shell ()@@ -262,17 +272,27 @@ , "HASTEC=\"$(dirname $0)/hastec\"" , "DIR=\"$($HASTEC --print-libdir)/../haste-cabal\"" , "export LD_LIBRARY_PATH=$DIR"- , "exec $DIR/haste-cabal.bin $@" ]+ , "args=\"\""+ , "for arg in \"$@\" ; do"+ , " args=\"$args \\\"$arg\\\"\""+ , "done"+ , "echo $args | xargs $DIR/haste-cabal.bin"+ ] hasteCabalLauncher False = unlines [ "#!/bin/bash" , "DIR=\"" ++ hasteCabalRootDir False </> "haste-cabal" ++ "\"" , "export LD_LIBRARY_PATH=$DIR"- , "exec $DIR/haste-cabal.bin $@" ]+ , "args=\"\""+ , "for arg in \"$@\" ; do"+ , " args=\"$args \\\"$arg\\\"\""+ , "done"+ , "echo $args | xargs $DIR/haste-cabal.bin"+ ] -- | Fetch the Haste base libs. fetchLibs :: FilePath -> Shell () fetchLibs tmpdir = do- echo "Downloading base libs from GitHub"+ logStr "Downloading base libs from GitHub" file <- fetchBytes $ mkUrl hasteVersion liftIO . unpack tmpdir . read . decompress $ BSL.fromChunks [file] where@@ -282,9 +302,9 @@ -- | Fetch and install the Closure compiler. installClosure :: FilePath -> Shell () installClosure dir = do- echo "Downloading Google Closure compiler..."+ logStr "Downloading Google Closure compiler..." downloadClosure `orElse` do- echo "Couldn't install Closure compiler; continuing without."+ logStr "Couldn't install Closure compiler; continuing without." where downloadClosure = do fetchBytes closureURI >>= (liftIO . BS.writeFile (dir </> closureCompiler))@@ -299,69 +319,70 @@ cpdir "include" hasteSysDir inDirectory ("utils" </> "unlit") $ do+ logStr "Building unlit" let out = if os == "mingw32" then "unlit.exe" else "unlit" static = if os == "darwin" then [] else ["-static"] dash_s = if os == "darwin" then [] else ["-s"]- run_ "gcc" (["-o" ++ out, "-O2", "unlit.c"]++static) ""- run_ "strip" (dash_s ++ [out]) ""+ run "gcc" (["-o" ++ out, "-O2", "unlit.c"]++static)+ run "strip" (dash_s ++ [out]) cp out (hasteSysDir </> out) - run_ hastePkgBinary ["update", "--global", "libraries" </> "rts.pkg"] ""+ logStr "Setting up builtin_rts"+ run hastePkgBinary ["update", "--global", "libraries" </> "rts.pkg"] inDirectory "libraries" $ do+ logStr "Installing libraries" inDirectory libDir $ do -- Install ghc-prim inDirectory "ghc-prim" $ do+ logStr "Installing ghc-prim" hasteCabal Install ["--solver", "topdown"] -- To get the GHC.Prim module in spite of pretending to have -- build-type: Simple+ logStr "Patching ghc-prim package info" let osxprim = if os == "darwin" then "-osx" else ""- run_ hastePkgBinary ["unregister", "--global","ghc-prim"] ""- run_ hastePkgBinary ["update", "--global",- "ghc-prim-"++primVersion++osxprim++".conf"] ""+ run hastePkgBinary ["unregister", "--global","ghc-prim"]+ run hastePkgBinary ["update", "--global",+ "ghc-prim-"++primVersion++osxprim++".conf"] -- Install integer-gmp; double install shouldn't be needed anymore. inDirectory "integer-gmp" $ do+ logStr "Installing integer-gmp" hasteCabal Install ["--solver", "topdown"] -- Install base inDirectory "base" $ do+ logStr "Installing base" hasteCabal Clean [] hasteCabal Install ["--solver", "topdown", "-finteger-gmp"] -- Install array- inDirectory "array" $ hasteCabal Clean []- inDirectory "array" $ hasteCabal Install []+ inDirectory "array" $ do+ logStr "Installing array"+ hasteCabal Clean []+ hasteCabal Install [] -- Install haste-prim- inDirectory "haste-prim" $ hasteCabal Install []+ inDirectory "haste-prim" $ do+ logStr "Installing haste-prim"+ hasteCabal Install [] -- Install time + hashable + haste-lib- inDirectory "time" $ hasteCabal Install []+ inDirectory "time" $ do+ logStr "Installing time"+ hasteCabal Install []++ logStr "Installing hashable + haste-lib" hasteCabal Install [ "hashable-1.2.4.0" , "-f-integer-gmp" , "-f-sse2" , "-f-sse41"- , "./haste-lib"- ]-- -- Install QuickCheck- libdir <- pwd- inTempDirectory $ do- hasteCabal (Do "unpack") ["QuickCheck-2.6"]- inDirectory "QuickCheck-2.6" $ do- run_ "patch" [ "-p1"- , "-i"- , libdir </> "quickcheck-2.6-amp.patch"- ] ""- hasteCabal Install [ "-f-templatehaskell"- , "--allow-newer=base"- , "./QuickCheck-2.6"- ]+ , "./haste-lib"] -- Export monads-tf; it seems to be hidden by default- run_ hastePkgBinary ["expose", "monads-tf"] ""+ logStr "Exposing monads-tf"+ run hastePkgBinary ["expose", "monads-tf"] where ghcOpts = concat [ if tracePrimops cfg then ["--hastec-option=-debug"] else [],@@ -374,28 +395,21 @@ , "--package-db=clear" , "--package-db=global" , "--hastec-option=-fforce-recomp"-#if __GLASGOW_HASKELL__ < 709- , "--hastec-option=-DHASTE_HOST_WORD_SIZE_IN_BITS=" ++- show hostWordSize-#endif ] hasteCabal Configure args =- withEnv "HASTE_BOOTING" (const "1") $ run_ hasteCabalBinary as ""+ withEnv "HASTE_BOOTING" "1" $ run hasteCabalBinary as where as = "configure" : args ++ ghcOpts ++ configOpts hasteCabal Install args =- withEnv "HASTE_BOOTING" (const "1") $ run_ hasteCabalBinary as ""+ withEnv "HASTE_BOOTING" "1" $ run hasteCabalBinary as where as = "install" : args ++ ghcOpts ++ configOpts hasteCabal Build args =- withEnv "HASTE_BOOTING" (const "1") $ run_ hasteCabalBinary as ""+ withEnv "HASTE_BOOTING" "1" $ run hasteCabalBinary as where as = "build" : args ++ ghcOpts hasteCabal Clean args =- withEnv "HASTE_BOOTING" (const "1") $ run_ hasteCabalBinary as ""+ withEnv "HASTE_BOOTING" "1" $ run hasteCabalBinary as where as = "clean" : args- hasteCabal (Do what) args =- withEnv "HASTE_BOOTING" (const "1") $ run_ hasteCabalBinary as ""- where as = what : args - vanillaCabal args = run_ "cabal" args ""+ vanillaCabal args = run "cabal" args -- | Copy GHC settings and utils into the given directory.@@ -410,4 +424,6 @@ #endif relocate :: String -> Shell ()-relocate pkg = run_ hastePkgBinary ["relocate", pkg] ""+relocate pkg = do+ logStr $ "Relocating " ++ pkg+ run hastePkgBinary ["relocate", pkg]
src/hastec.hs view
@@ -2,11 +2,8 @@ -- | Haste's main compiler driver. module Main where import Language.Haskell.GHC.Simple as GHC-#if __GLASGOW_HASKELL__ >= 710 import Language.Haskell.GHC.Simple.PrimIface import Packages-import PackageConfig-#endif import GHC import Outputable (showPpr) import Platform@@ -64,11 +61,7 @@ then buildJSLib prof cfg (fst $ head targets) mods else mapM_ (uncurry $ linkAndMinify cfg) targets where-#if __GLASGOW_HASKELL__ >= 710 getExtraLibDirs = fmap (concatMap libraryDirs) . readPackageConfigs-#else- getExtraLibDirs = const (return [])-#endif pkgs booting = ["-no-global-package-db",@@ -122,9 +115,7 @@ } } }-#if __GLASGOW_HASKELL__ >= 710 , cfgCustomPrimIface = Just (primOpInfo, primOpStrictness)-#endif } mkLinkerCfg dfs extralibdirs cfg = cfg { mainMod = Just (pkgKeyString $ modulePkgKey (mainModIs dfs),@@ -133,15 +124,14 @@ } setShowOutputable dfs cfg = cfg {showOutputable = showPpr dfs} -#if __GLASGOW_HASKELL__ >= 710 -- | Primop info for custom GHC.Prim interface. primOpInfo :: PrimOp -> PrimOpInfo #include "primop-info-710.hs"+primOpInfo _ = error "Nonexistent primop!" -- | Strictness info for custom GHC.Prim interface. primOpStrictness :: PrimOp -> Arity -> StrictSig #include "primop-stricts-710.hs"-#endif -- | Compile an STG module into a JS module and write it to its appropriate -- location according to the given config.@@ -164,7 +154,7 @@ Just clopath -> closurize cfg clopath outfile _ -> return () when (outputHTML cfg) $ do- res <- Sh.shell $ Sh.withCustomTempFile "." $ \tmp h -> do+ res <- Sh.shell $ Sh.withCustomTempFile Sh.TextMode "." $ \tmp h -> do prog <- Sh.input outfile Sh.hPutStrLn h (htmlSkeleton outfile prog) Sh.liftIO $ hClose h@@ -182,6 +172,7 @@ "<html><head>", "<title>", filename , "</title>", "<meta charset=\"UTF-8\">",+ "<meta http-equiv=\"x-ua-compatible\" content=\"ie=edge, chrome=1\">", "<script type=\"text/javascript\">", prog, "</script>", "</head><body></body></html>"] @@ -192,24 +183,28 @@ logStr cfg $ "Minifying " ++ f ++ "..." let cloFile = f `Sh.addExtension` ".clo" res <- Sh.shell $ do- str <- Sh.run "java"- (["-jar", cloPath,- "--compilation_level", "ADVANCED_OPTIMIZATIONS",- "--jscomp_off", "globalThis", f]- ++ arguments) ""- Sh.output cloFile str+ Sh.run "java" (cloArgs arguments cloFile) Sh.mv cloFile f case res of Left e -> fail $ "Couldn't execute Google Closure compiler: " ++ Sh.exitString e Right _ -> return ()+ where+ cloArgs args cloFile =+ [ "-jar"+ , cloPath+ , "--compilation_level", "ADVANCED_OPTIMIZATIONS"+ , "--jscomp_off", "globalThis"+ , "--js_output_file", cloFile+ , f+ ] ++ args + -- | Call vanilla GHC; used for C files and the like. callVanillaGHC :: [String] -> IO () callVanillaGHC args = do booting <- maybe False (const True) `fmap` lookupEnv "HASTE_BOOTING"- _ <- Sh.shell $ Sh.run_ ghcBinary (pkgargs booting ++ ghcArgs) ""- return ()+ Sh.shell_ $ Sh.run ghcBinary (pkgargs booting ++ ghcArgs) where Right (_, ghcArgs, _) = parseArgs hasteOpts "" args pkgargs booting =@@ -223,12 +218,11 @@ -- | Initialize the Haste package database, unless it already exists. initUserPkgDB :: IO () initUserPkgDB = do- _ <- Sh.shell $ do+ Sh.shell_ $ do pkgDirExists <- Sh.isDirectory pkgUserDir when (not pkgDirExists) $ do Sh.mkdir True pkgUserLibDir- Sh.runInteractive hastePkgBinary ["init", pkgUserDir]- return ()+ Sh.run hastePkgBinary ["init", pkgUserDir] type Message = String data Compiler = Haste | GHC | InstallJSExe | BuildRunner deriving (Show, Eq)@@ -265,9 +259,10 @@ -> Either (IO ()) ([String], Config->Config) parseHasteFlags booting args rawargs = do case runMode booting args of+ _ | null rawargs -> Left $ putStrLn noInputFiles DontRun msg -> Left $ putStrLn msg- Run GHC -> Left $ callVanillaGHC args- Run Haste -> do+ Run GHC -> Left $ callVanillaGHC args+ Run Haste -> do case parseArgs hasteOpts helpHeader args of Left msg -> Left $ putStrLn msg Right (cfg, rest, []) -> Right (filter (/= "-prof") rest, cfg)@@ -277,6 +272,10 @@ Run BuildRunner -> do Left $ callVanillaGHC (rawargs ++ ["-package-id", "Cabal-1.23.0.0-f701f4ea98ec7bed5883c4df743045e6"]) where+ noInputFiles = init $ unlines+ [ "hastec: no input files"+ , "try the `--help' option for usage information"+ ] jsexeIn ("--install-executable":exe:_) = exe jsexeIn (_:xs) = jsexeIn xs jsexeIn _ = error "No executable to install!"
− utils/haste-pkg/HastePkg708.hs
@@ -1,1834 +0,0 @@-{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-}------------------------------------------------------------------------------------ (c) The University of Glasgow 2004-2009.------ Package management tool-----------------------------------------------------------------------------------module HastePkg708 (main) where--import Distribution.InstalledPackageInfo.Binary()-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.ModuleName hiding (main)-import Distribution.InstalledPackageInfo-import Distribution.Compat.ReadP-import Distribution.ParseUtils-import Distribution.Package hiding (depends)-import Distribution.Text-import Distribution.Version-import System.FilePath as FilePath-import qualified System.FilePath.Posix as FilePath.Posix-import System.Process-import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,- getModificationTime )-import Text.Printf--import Prelude--import System.Console.GetOpt-import qualified Control.Exception as Exception-import Data.Maybe--import Data.Char ( isSpace, toLower )-import Data.Ord (comparing)-import Control.Applicative (Applicative(..))-import Control.Monad-import System.Directory ( doesDirectoryExist, getDirectoryContents,- doesFileExist, renameFile, removeFile,- getCurrentDirectory )-import System.Exit ( exitWith, ExitCode(..) )-import System.Environment ( getArgs, getProgName, getEnv )-import System.IO-import System.IO.Error-import Data.List-import Control.Concurrent--import qualified Data.ByteString.Lazy as B-import qualified Data.Binary as Bin-import qualified Data.Binary.Get as Bin---- Haste-specific-import Haste.Environment-import Haste.Version-import System.Info (os)-import qualified Control.Shell as Sh--#if defined(mingw32_HOST_OS)--- mingw32 needs these for getExecDir-import Foreign-import Foreign.C-#endif--#ifdef mingw32_HOST_OS-import GHC.ConsoleHandler-#else-import System.Posix hiding (fdToHandle)-#endif--#if defined(GLOB)-import qualified System.Info(os)-#endif--#if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING)-import System.Console.Terminfo as Terminfo-#endif--#ifdef mingw32_HOST_OS-# if defined(i386_HOST_ARCH)-# define WINDOWS_CCONV stdcall-# elif defined(x86_64_HOST_ARCH)-# define WINDOWS_CCONV ccall-# else-# error Unknown mingw32 arch-# endif-#endif---- -------------------------------------------------------------------------------- Entry point--main :: IO ()-main = do- args <- getArgs-- case args of- ["relocate", pkg] -> do- Sh.shell (relocate packages pkg) >> exitWith ExitSuccess- _ ->- return ()-- case getOpt Permute (flags ++ deprecFlags) args of- (cli,_,[]) | FlagHelp `elem` cli -> do- prog <- getProgramName- bye (usageInfo (usageHeader prog) flags)- (cli,_,[]) | FlagVersion `elem` cli ->- bye ourCopyright- (cli,_,[]) | FlagNumericVersion `elem` cli ->- bye $ showVersion hasteVersion ++ "\n"- (cli,_,[]) | FlagNumericGhcVersion `elem` cli ->- bye $ showVersion ghcVersion ++ "\n"- (cli,nonopts,[]) ->- case getVerbosity Normal cli of- Right v -> runit v cli nonopts- Left err -> die err- (_,_,errors) -> do- prog <- getProgramName- die (concat errors ++ shortUsage prog)- where- packages = ["--global-package-db=" ++ pkgSysDir,- "--package-db=" ++ pkgSysDir,- "--package-db=" ++ pkgUserDir]---- -------------------------------------------------------------------------------- Command-line syntax--data Flag- = FlagUser- | FlagGlobal- | FlagHelp- | FlagVersion- | FlagNumericVersion- | FlagNumericGhcVersion- | FlagConfig FilePath- | FlagGlobalConfig FilePath- | FlagForce- | FlagForceFiles- | FlagAutoGHCiLibs- | FlagExpandEnvVars- | FlagExpandPkgroot- | FlagNoExpandPkgroot- | FlagSimpleOutput- | FlagNamesOnly- | FlagIgnoreCase- | FlagNoUserDb- | FlagVerbosity (Maybe String)- deriving Eq--flags :: [OptDescr Flag]-flags = [- Option [] ["user"] (NoArg FlagUser)- "use the current user's package database",- Option [] ["global"] (NoArg FlagGlobal)- "use the global package database",- Option ['f'] ["package-db"] (ReqArg FlagConfig "FILE/DIR")- "use the specified package database",- Option [] ["package-conf"] (ReqArg FlagConfig "FILE/DIR")- "use the specified package database (DEPRECATED)",- Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "DIR")- "location of the global package database",- Option [] ["no-user-package-db"] (NoArg FlagNoUserDb)- "never read the user package database",- Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)- "never read the user package database (DEPRECATED)",- Option [] ["force"] (NoArg FlagForce)- "ignore missing dependencies, directories, and libraries",- Option [] ["force-files"] (NoArg FlagForceFiles)- "ignore missing directories and libraries only",- Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)- "automatically build libs for GHCi (with register)",- Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)- "expand environment variables (${name}-style) in input package descriptions",- Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)- "expand ${pkgroot}-relative paths to absolute in output package descriptions",- Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)- "preserve ${pkgroot}-relative paths in output package descriptions",- Option ['?'] ["help"] (NoArg FlagHelp)- "display this help and exit",- Option ['V'] ["version"] (NoArg FlagVersion)- "output version information and exit",- Option [] ["numeric-version"] (NoArg FlagNumericVersion)- "output version number and exit",- Option [] ["numeric-ghc-version"] (NoArg FlagNumericGhcVersion)- "output GHC version number and exit",- Option [] ["simple-output"] (NoArg FlagSimpleOutput)- "print output in easy-to-parse format for some commands",- Option [] ["names-only"] (NoArg FlagNamesOnly)- "only print package names, not versions; can only be used with list --simple-output",- Option [] ["ignore-case"] (NoArg FlagIgnoreCase)- "ignore case for substring matching",- Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")- "verbosity level (0-2, default 1)"- ]--data Verbosity = Silent | Normal | Verbose- deriving (Show, Eq, Ord)--getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity-getVerbosity v [] = Right v-getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs-getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs-getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs-getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs-getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)-getVerbosity v (_ : fs) = getVerbosity v fs--deprecFlags :: [OptDescr Flag]-deprecFlags = [- -- put deprecated flags here- ]--ourCopyright :: String-ourCopyright = "Haste package manager version " ++ showVersion hasteVersion ++ "\n"--shortUsage :: String -> String-shortUsage prog = "For usage information see '" ++ prog ++ " --help'."--usageHeader :: String -> String-usageHeader prog = substProg prog $- "Usage:\n" ++- " $p init {path}\n" ++- " Create and initialise a package database at the location {path}.\n" ++- " Packages can be registered in the new database using the register\n" ++- " command with --package-db={path}. To use the new database with GHC,\n" ++- " use GHC's -package-db flag.\n" ++- "\n" ++- " $p register {filename | -}\n" ++- " Register the package using the specified installed package\n" ++- " description. The syntax for the latter is given in the $p\n" ++- " documentation. The input file should be encoded in UTF-8.\n" ++- "\n" ++- " $p update {filename | -}\n" ++- " Register the package, overwriting any other package with the\n" ++- " same name. The input file should be encoded in UTF-8.\n" ++- "\n" ++- " $p unregister {pkg-id}\n" ++- " Unregister the specified package.\n" ++- "\n" ++- " $p expose {pkg-id}\n" ++- " Expose the specified package.\n" ++- "\n" ++- " $p hide {pkg-id}\n" ++- " Hide the specified package.\n" ++- "\n" ++- " $p trust {pkg-id}\n" ++- " Trust the specified package.\n" ++- "\n" ++- " $p distrust {pkg-id}\n" ++- " Distrust the specified package.\n" ++- "\n" ++- " $p list [pkg]\n" ++- " List registered packages in the global database, and also the\n" ++- " user database if --user is given. If a package name is given\n" ++- " all the registered versions will be listed in ascending order.\n" ++- " Accepts the --simple-output flag.\n" ++- "\n" ++- " $p dot\n" ++- " Generate a graph of the package dependencies in a form suitable\n" ++- " for input for the graphviz tools. For example, to generate a PDF" ++- " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++- "\n" ++- " $p find-module {module}\n" ++- " List registered packages exposing module {module} in the global\n" ++- " database, and also the user database if --user is given.\n" ++- " All the registered versions will be listed in ascending order.\n" ++- " Accepts the --simple-output flag.\n" ++- "\n" ++- " $p latest {pkg-id}\n" ++- " Prints the highest registered version of a package.\n" ++- "\n" ++- " $p check\n" ++- " Check the consistency of package dependencies and list broken packages.\n" ++- " Accepts the --simple-output flag.\n" ++- "\n" ++- " $p describe {pkg}\n" ++- " Give the registered description for the specified package. The\n" ++- " description is returned in precisely the syntax required by $p\n" ++- " register.\n" ++- "\n" ++- " $p field {pkg} {field}\n" ++- " Extract the specified field of the package description for the\n" ++- " specified package. Accepts comma-separated multiple fields.\n" ++- "\n" ++- " $p dump\n" ++- " Dump the registered description for every package. This is like\n" ++- " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++- " by tools that parse the results, rather than humans. The output is\n" ++- " always encoded in UTF-8, regardless of the current locale.\n" ++- "\n" ++- " $p recache\n" ++- " Regenerate the package database cache. This command should only be\n" ++- " necessary if you added a package to the database by dropping a file\n" ++- " into the database directory manually. By default, the global DB\n" ++- " is recached; to recache a different DB use --user or --package-db\n" ++- " as appropriate.\n" ++- "\n" ++- " Substring matching is supported for {module} in find-module and\n" ++- " for {pkg} in list, describe, and field, where a '*' indicates\n" ++- " open substring ends (prefix*, *suffix, *infix*).\n" ++- "\n" ++- " When asked to modify a database (register, unregister, update,\n"++- " hide, expose, and also check), ghc-pkg modifies the global database by\n"++- " default. Specifying --user causes it to act on the user database,\n"++- " or --package-db can be used to act on another database\n"++- " entirely. When multiple of these options are given, the rightmost\n"++- " one is used as the database to act upon.\n"++- "\n"++- " Commands that query the package database (list, tree, latest, describe,\n"++- " field) operate on the list of databases specified by the flags\n"++- " --user, --global, and --package-db. If none of these flags are\n"++- " given, the default is --global --user.\n"++- "\n" ++- " The following optional flags are also accepted:\n"--substProg :: String -> String -> String-substProg _ [] = []-substProg prog ('$':'p':xs) = prog ++ substProg prog xs-substProg prog (c:xs) = c : substProg prog xs---- -------------------------------------------------------------------------------- Do the business--data Force = NoForce | ForceFiles | ForceAll | CannotForce- deriving (Eq,Ord)--data PackageArg = Id PackageIdentifier | Substring String (String->Bool)--runit :: Verbosity -> [Flag] -> [String] -> IO ()-runit verbosity cli nonopts = do- installSignalHandlers -- catch ^C and clean up- prog <- getProgramName- let- force- | FlagForce `elem` cli = ForceAll- | FlagForceFiles `elem` cli = ForceFiles- | otherwise = NoForce- auto_ghci_libs = FlagAutoGHCiLibs `elem` cli- expand_env_vars= FlagExpandEnvVars `elem` cli- mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli- where accumExpandPkgroot _ FlagExpandPkgroot = Just True- accumExpandPkgroot _ FlagNoExpandPkgroot = Just False- accumExpandPkgroot x _ = x- - splitFields fields = unfoldr splitComma (',':fields)- where splitComma "" = Nothing- splitComma fs = Just $ break (==',') (tail fs)-- substringCheck :: String -> Maybe (String -> Bool)- substringCheck "" = Nothing- substringCheck "*" = Just (const True)- substringCheck [_] = Nothing- substringCheck (h:t) =- case (h, init t, last t) of- ('*',s,'*') -> Just (isInfixOf (f s) . f)- ('*',_, _ ) -> Just (isSuffixOf (f t) . f)- ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)- _ -> Nothing- where f | FlagIgnoreCase `elem` cli = map toLower- | otherwise = id-#if defined(GLOB)- glob x | System.Info.os=="mingw32" = do- -- glob echoes its argument, after win32 filename globbing- (_,o,_,_) <- runInteractiveCommand ("glob "++x)- txt <- hGetContents o- return (read txt)- glob x | otherwise = return [x]-#endif- --- -- first, parse the command- case nonopts of-#if defined(GLOB)- -- dummy command to demonstrate usage and permit testing- -- without messing things up; use glob to selectively enable- -- windows filename globbing for file parameters- -- register, update, FlagGlobalConfig, FlagConfig; others?- ["glob", filename] -> do- print filename- glob filename >>= print-#endif- ["init", filename] ->- initPackageDB filename verbosity cli- ["register", filename] ->- registerPackage filename verbosity cli- auto_ghci_libs expand_env_vars False force- ["update", filename] ->- registerPackage filename verbosity cli- auto_ghci_libs expand_env_vars True force- ["unregister", pkgid_str] -> do- pkgid <- readGlobPkgId pkgid_str- unregisterPackage pkgid verbosity cli force- ["expose", pkgid_str] -> do- pkgid <- readGlobPkgId pkgid_str- exposePackage pkgid verbosity cli force- ["hide", pkgid_str] -> do- pkgid <- readGlobPkgId pkgid_str- hidePackage pkgid verbosity cli force- ["trust", pkgid_str] -> do- pkgid <- readGlobPkgId pkgid_str- trustPackage pkgid verbosity cli force- ["distrust", pkgid_str] -> do- pkgid <- readGlobPkgId pkgid_str- distrustPackage pkgid verbosity cli force- ["list"] -> do- listPackages verbosity cli Nothing Nothing- ["list", pkgid_str] ->- case substringCheck pkgid_str of- Nothing -> do pkgid <- readGlobPkgId pkgid_str- listPackages verbosity cli (Just (Id pkgid)) Nothing- Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing- ["dot"] -> do- showPackageDot verbosity cli- ["find-module", moduleName] -> do- let match = maybe (==moduleName) id (substringCheck moduleName)- listPackages verbosity cli Nothing (Just match)- ["latest", pkgid_str] -> do- pkgid <- readGlobPkgId pkgid_str- latestPackage verbosity cli pkgid- ["describe", pkgid_str] -> do- pkgarg <- case substringCheck pkgid_str of- Nothing -> liftM Id (readGlobPkgId pkgid_str)- Just m -> return (Substring pkgid_str m)- describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)- - ["field", pkgid_str, fields] -> do- pkgarg <- case substringCheck pkgid_str of- Nothing -> liftM Id (readGlobPkgId pkgid_str)- Just m -> return (Substring pkgid_str m)- describeField verbosity cli pkgarg- (splitFields fields) (fromMaybe True mexpand_pkgroot)-- ["check"] -> do- checkConsistency verbosity cli-- ["dump"] -> do- dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)-- ["recache"] -> do- recache verbosity cli-- [] -> do- die ("missing command\n" ++ shortUsage prog)- (_cmd:_) -> do- die ("command-line syntax error\n" ++ shortUsage prog)--parseCheck :: ReadP a a -> String -> String -> IO a-parseCheck parser str what =- case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of- [x] -> return x- _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)--readGlobPkgId :: String -> IO PackageIdentifier-readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"--parseGlobPackageId :: ReadP r PackageIdentifier-parseGlobPackageId =- parse- +++- (do n <- parse- _ <- string "-*"- return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))---- globVersion means "all versions"-globVersion :: Version-globVersion = Version{ versionBranch=[], versionTags=["*"] }---- -------------------------------------------------------------------------------- Package databases---- Some commands operate on a single database:--- register, unregister, expose, hide, trust, distrust--- however these commands also check the union of the available databases--- in order to check consistency. For example, register will check that--- dependencies exist before registering a package.------ Some commands operate on multiple databases, with overlapping semantics:--- list, describe, field--data PackageDB - = PackageDB {- location, locationAbsolute :: !FilePath,- -- We need both possibly-relative and definately-absolute package- -- db locations. This is because the relative location is used as- -- an identifier for the db, so it is important we do not modify it.- -- On the other hand we need the absolute path in a few places- -- particularly in relation to the ${pkgroot} stuff.- - packages :: [InstalledPackageInfo]- }--type PackageDBStack = [PackageDB]- -- A stack of package databases. Convention: head is the topmost- -- in the stack.--allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]-allPackagesInStack = concatMap packages--getPkgDatabases :: Verbosity- -> Bool -- we are modifying, not reading- -> Bool -- read caches, if available- -> Bool -- expand vars, like ${pkgroot} and $topdir- -> [Flag]- -> IO (PackageDBStack, - -- the real package DB stack: [global,user] ++ - -- DBs specified on the command line with -f.- Maybe FilePath,- -- which one to modify, if any- PackageDBStack)- -- the package DBs specified on the command- -- line, or [global,user] otherwise. This- -- is used as the list of package DBs for- -- commands that just read the DB, such as 'list'.--getPkgDatabases verbosity modify use_cache expand_vars my_flags = do- -- first we determine the location of the global package config. On Windows,- -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the- -- location is passed to the binary using the --global-package-db flag by the- -- wrapper script.- let err_msg = "missing --global-package-db option, location of global package database unknown\n"- global_conf <-- case [ f | FlagGlobalConfig f <- my_flags ] of- [] -> do mb_dir <- getLibDir- case mb_dir of- Nothing -> die err_msg- Just dir -> do- r <- lookForPackageDBIn dir- case r of- Nothing -> die ("Can't find package database in " ++ dir)- Just path -> return path- fs -> return (last fs)-- -- The value of the $topdir variable used in some package descriptions- -- Note that the way we calculate this is slightly different to how it- -- is done in ghc itself. We rely on the convention that the global- -- package db lives in ghc's libdir.- top_dir <- absolutePath (takeDirectory global_conf)-- let no_user_db = FlagNoUserDb `elem` my_flags-- mb_user_conf <-- if no_user_db then return Nothing else do- r <- lookForPackageDBIn hasteUserDir- case r of- Nothing -> return (Just (pkgUserDir, False))- Just f -> return (Just (f, True))-- -- If the user database doesn't exist, and this command isn't a- -- "modify" command, then we won't attempt to create or use it.- let sys_databases- | Just (user_conf,user_exists) <- mb_user_conf,- modify || user_exists = [user_conf, global_conf]- | otherwise = [global_conf]-- e_pkg_path <- tryIO (System.Environment.getEnv "HASTE_PACKAGE_PATH")- let env_stack =- case e_pkg_path of- Left _ -> sys_databases- Right path- | last cs == "" -> init cs ++ sys_databases- | otherwise -> cs- where cs = parseSearchPath path-- -- The "global" database is always the one at the bottom of the stack.- -- This is the database we modify by default.- virt_global_conf = last env_stack-- let db_flags = [ f | Just f <- map is_db_flag my_flags ]- where is_db_flag FlagUser- | Just (user_conf, _user_exists) <- mb_user_conf - = Just user_conf- is_db_flag FlagGlobal = Just virt_global_conf- is_db_flag (FlagConfig f) = Just f- is_db_flag _ = Nothing-- let flag_db_names | null db_flags = env_stack- | otherwise = reverse (nub db_flags)-- -- For a "modify" command, treat all the databases as- -- a stack, where we are modifying the top one, but it- -- can refer to packages in databases further down the- -- stack.-- -- -f flags on the command line add to the database- -- stack, unless any of them are present in the stack- -- already.- let final_stack = filter (`notElem` env_stack)- [ f | FlagConfig f <- reverse my_flags ]- ++ env_stack-- -- the database we actually modify is the one mentioned- -- rightmost on the command-line.- let to_modify- | not modify = Nothing- | null db_flags = Just virt_global_conf- | otherwise = Just (last db_flags)-- db_stack <- sequence- [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path- if expand_vars then return (mungePackageDBPaths top_dir db)- else return db- | db_path <- final_stack ]-- let flag_db_stack = [ db | db_name <- flag_db_names,- db <- db_stack, location db == db_name ]-- return (db_stack, to_modify, flag_db_stack)---lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)-lookForPackageDBIn dir = do- let path_dir = dir </> "package.conf.d"- exists_dir <- doesDirectoryExist path_dir- if exists_dir then return (Just path_dir) else do- let path_file = dir </> "package.conf"- exists_file <- doesFileExist path_file- if exists_file then return (Just path_file) else return Nothing--readParseDatabase :: Verbosity- -> Maybe (FilePath,Bool)- -> Bool -- use cache- -> FilePath- -> IO PackageDB--readParseDatabase verbosity mb_user_conf use_cache path- -- the user database (only) is allowed to be non-existent- | Just (user_conf,False) <- mb_user_conf, path == user_conf- = mkPackageDB []- | otherwise- = do e <- tryIO $ getDirectoryContents path- case e of- Left _ -> do- pkgs <- parseMultiPackageConf verbosity path- mkPackageDB pkgs- Right fs- | not use_cache -> ignore_cache (const $ return ())- | otherwise -> do- let cache = path </> cachefilename- tdir <- getModificationTime path- e_tcache <- tryIO $ getModificationTime cache- case e_tcache of- Left ex -> do- when (verbosity > Normal) $- warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)- ignore_cache (const $ return ())- Right tcache -> do- let compareTimestampToCache file =- when (verbosity >= Verbose) $ do- tFile <- getModificationTime file- compareTimestampToCache' file tFile- compareTimestampToCache' file tFile = do- let rel = case tcache `compare` tFile of- LT -> " (NEWER than cache)"- GT -> " (older than cache)"- EQ -> " (same as cache)"- warn ("Timestamp " ++ show tFile- ++ " for " ++ file ++ rel)- when (verbosity >= Verbose) $ do- warn ("Timestamp " ++ show tcache ++ " for " ++ cache)- compareTimestampToCache' path tdir- if tcache >= tdir- then do- when (verbosity > Normal) $- infoLn ("using cache: " ++ cache)- pkgs <- myReadBinPackageDB cache- let pkgs' = map convertPackageInfoIn pkgs- mkPackageDB pkgs'- else do- when (verbosity >= Normal) $ do- warn ("WARNING: cache is out of date: "- ++ cache)- warn "Use 'ghc-pkg recache' to fix."- ignore_cache compareTimestampToCache- where- ignore_cache :: (FilePath -> IO ()) -> IO PackageDB- ignore_cache checkTime = do- let confs = filter (".conf" `isSuffixOf`) fs- doFile f = do checkTime f- parseSingletonPackageConf verbosity f- pkgs <- mapM doFile $ map (path </>) confs- mkPackageDB pkgs- where- mkPackageDB pkgs = do- path_abs <- absolutePath path- return PackageDB {- location = path,- locationAbsolute = path_abs,- packages = pkgs- }---- read the package.cache file strictly, to work around a problem with--- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed--- after it has been completely read, leading to a sharing violation--- later.-myReadBinPackageDB :: FilePath -> IO [InstalledPackageInfoString]-myReadBinPackageDB filepath = do- h <- openBinaryFile filepath ReadMode- sz <- hFileSize h- b <- B.hGet h (fromIntegral sz)- hClose h- return $ Bin.runGet Bin.get b--parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]-parseMultiPackageConf verbosity file = do- when (verbosity > Normal) $ infoLn ("reading package database: " ++ file)- str <- readUTF8File file- let pkgs = map convertPackageInfoIn $ read str- Exception.evaluate pkgs- `catchError` \e->- die ("error while parsing " ++ file ++ ": " ++ show e)- -parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo-parseSingletonPackageConf verbosity file = do- when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)- readUTF8File file >>= fmap fst . parsePackageInfo--cachefilename :: FilePath-cachefilename = "package.cache"--mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB-mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =- db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }- where- pkgroot = takeDirectory (locationAbsolute db) - -- It so happens that for both styles of package db ("package.conf"- -- files and "package.conf.d" dirs) the pkgroot is the parent directory- -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/---- TODO: This code is duplicated in compiler/main/Packages.lhs-mungePackagePaths :: FilePath -> FilePath- -> InstalledPackageInfo -> InstalledPackageInfo--- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec--- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)--- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.--- The "pkgroot" is the directory containing the package database.------ Also perform a similar substitution for the older GHC-specific--- "$topdir" variable. The "topdir" is the location of the ghc--- installation (obtained from the -B option).-mungePackagePaths top_dir pkgroot pkg =- pkg {- importDirs = munge_paths (importDirs pkg),- includeDirs = munge_paths (includeDirs pkg),- libraryDirs = munge_paths (libraryDirs pkg),- frameworkDirs = munge_paths (frameworkDirs pkg),- haddockInterfaces = munge_paths (haddockInterfaces pkg),- -- haddock-html is allowed to be either a URL or a file- haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))- }- where- munge_paths = map munge_path- munge_urls = map munge_url-- munge_path p- | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'- | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'- | otherwise = p-- munge_url p- | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'- | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'- | otherwise = p-- toUrlPath r p = "file:///"- -- URLs always use posix style '/' separators:- ++ FilePath.Posix.joinPath- (r : -- We need to drop a leading "/" or "\\"- -- if there is one:- dropWhile (all isPathSeparator)- (FilePath.splitDirectories p))-- -- We could drop the separator here, and then use </> above. However,- -- by leaving it in and using ++ we keep the same path separator- -- rather than letting FilePath change it to use \ as the separator- stripVarPrefix var path = case stripPrefix var path of- Just [] -> Just []- Just cs@(c : _) | isPathSeparator c -> Just cs- _ -> Nothing----- -------------------------------------------------------------------------------- Creating a new package DB--initPackageDB :: FilePath -> Verbosity -> [Flag] -> IO ()-initPackageDB filename verbosity _flags = do- let eexist = die ("cannot create: " ++ filename ++ " already exists")- b1 <- doesFileExist filename- when b1 eexist- b2 <- doesDirectoryExist filename- when b2 eexist- filename_abs <- absolutePath filename- changeDB verbosity [] PackageDB {- location = filename, locationAbsolute = filename_abs,- packages = []- }---- -------------------------------------------------------------------------------- Registering--registerPackage :: FilePath- -> Verbosity- -> [Flag]- -> Bool -- auto_ghci_libs- -> Bool -- expand_env_vars- -> Bool -- update- -> Force- -> IO ()-registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do- (db_stack, Just to_modify, _flag_dbs) <- - getPkgDatabases verbosity True True False{-expand vars-} my_flags-- let- db_to_operate_on = my_head "register" $- filter ((== to_modify).location) db_stack- --- when (auto_ghci_libs && verbosity >= Silent) $- warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"- --- s <-- case input of- "-" -> do- when (verbosity >= Normal) $- info "Reading package info from stdin ... "- -- fix the encoding to UTF-8, since this is an interchange format- hSetEncoding stdin utf8- getContents- f -> do- when (verbosity >= Normal) $- info ("Reading package info from " ++ show f ++ " ... ")- readUTF8File f-- expanded <- if expand_env_vars then expandEnvVars s force- else return s-- (pkg, ws) <- parsePackageInfo expanded- when (verbosity >= Normal) $- infoLn "done."-- -- report any warnings from the parse phase- _ <- reportValidateErrors [] ws- (display (sourcePackageId pkg) ++ ": Warning: ") Nothing-- -- validate the expanded pkg, but register the unexpanded- pkgroot <- absolutePath (takeDirectory to_modify)- let top_dir = takeDirectory (location (last db_stack))- pkg_expanded = mungePackagePaths top_dir pkgroot pkg-- let truncated_stack = dropWhile ((/= to_modify).location) db_stack- -- truncate the stack for validation, because we don't allow- -- packages lower in the stack to refer to those higher up.- validatePackageConfig pkg_expanded verbosity truncated_stack auto_ghci_libs update force- let - removes = [ RemovePackage p- | p <- packages db_to_operate_on,- sourcePackageId p == sourcePackageId pkg ]- --- changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on--parsePackageInfo- :: String- -> IO (InstalledPackageInfo, [ValidateWarning])-parsePackageInfo str =- case parseInstalledPackageInfo str of- ParseOk warnings ok -> return (ok, ws)- where- ws = [ msg | PWarning msg <- warnings- , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]- ParseFailed err -> case locatedErrorMsg err of- (Nothing, s) -> die s- (Just l, s) -> die (show l ++ ": " ++ s)---- -------------------------------------------------------------------------------- Making changes to a package database--data DBOp = RemovePackage InstalledPackageInfo- | AddPackage InstalledPackageInfo- | ModifyPackage InstalledPackageInfo--changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()-changeDB verbosity cmds db = do- let db' = updateInternalDB db cmds- isfile <- doesFileExist (location db)- if isfile- then writeNewConfig verbosity (location db') (packages db')- else do- createDirectoryIfMissing True (location db)- changeDBDir verbosity cmds db'--updateInternalDB :: PackageDB -> [DBOp] -> PackageDB-updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }- where- do_cmd pkgs (RemovePackage p) = - filter ((/= installedPackageId p) . installedPackageId) pkgs- do_cmd pkgs (AddPackage p) = p : pkgs- do_cmd pkgs (ModifyPackage p) = - do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)- --changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()-changeDBDir verbosity cmds db = do- mapM_ do_cmd cmds- updateDBCache verbosity db- where- do_cmd (RemovePackage p) = do- let file = location db </> display (installedPackageId p) <.> "conf"- when (verbosity > Normal) $ infoLn ("removing " ++ file)- removeFileSafe file- do_cmd (AddPackage p) = do- let file = location db </> display (installedPackageId p) <.> "conf"- when (verbosity > Normal) $ infoLn ("writing " ++ file)- writeFileUtf8Atomic file (showInstalledPackageInfo p)- do_cmd (ModifyPackage p) = - do_cmd (AddPackage p)--updateDBCache :: Verbosity -> PackageDB -> IO ()-updateDBCache verbosity db = do- let filename = location db </> cachefilename- when (verbosity > Normal) $- infoLn ("writing cache " ++ filename)- writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))- `catchIO` \e ->- if isPermissionError e- then die (filename ++ ": you don't have permission to modify this file")- else ioError e-#ifndef mingw32_HOST_OS- status <- getFileStatus filename- setFileTimes (location db) (accessTime status) (modificationTime status)-#endif---- -------------------------------------------------------------------------------- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar--exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()-exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True})--hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()-hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False})--trustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()-trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True})--distrustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()-distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False})--unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()-unregisterPackage = modifyPackage RemovePackage--modifyPackage- :: (InstalledPackageInfo -> DBOp)- -> PackageIdentifier- -> Verbosity- -> [Flag]- -> Force- -> IO ()-modifyPackage fn pkgid verbosity my_flags force = do- (db_stack, Just _to_modify, _flag_dbs) <- - getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags-- (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)- let - db_name = location db- pkgs = packages db-- pids = map sourcePackageId ps-- cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]- new_db = updateInternalDB db cmds-- old_broken = brokenPackages (allPackagesInStack db_stack)- rest_of_stack = filter ((/= db_name) . location) db_stack- new_stack = new_db : rest_of_stack- new_broken = map sourcePackageId (brokenPackages (allPackagesInStack new_stack))- newly_broken = filter (`notElem` map sourcePackageId old_broken) new_broken- --- when (not (null newly_broken)) $- dieOrForceAll force ("unregistering " ++ display pkgid ++- " would break the following packages: "- ++ unwords (map display newly_broken))-- changeDB verbosity cmds db--recache :: Verbosity -> [Flag] -> IO ()-recache verbosity my_flags = do- (db_stack, Just to_modify, _flag_dbs) <- - getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags- let- db_to_operate_on = my_head "recache" $- filter ((== to_modify).location) db_stack- --- changeDB verbosity [] db_to_operate_on---- -------------------------------------------------------------------------------- Listing packages--listPackages :: Verbosity -> [Flag] -> Maybe PackageArg- -> Maybe (String->Bool)- -> IO ()-listPackages verbosity my_flags mPackageName mModuleName = do- let simple_output = FlagSimpleOutput `elem` my_flags- (db_stack, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags-- let db_stack_filtered -- if a package is given, filter out all other packages- | Just this <- mPackageName =- [ db{ packages = filter (this `matchesPkg`) (packages db) }- | db <- flag_db_stack ]- | Just match <- mModuleName = -- packages which expose mModuleName- [ db{ packages = filter (match `exposedInPkg`) (packages db) }- | db <- flag_db_stack ]- | otherwise = flag_db_stack-- db_stack_sorted- = [ db{ packages = sort_pkgs (packages db) }- | db <- db_stack_filtered ]- where sort_pkgs = sortBy cmpPkgIds- cmpPkgIds pkg1 pkg2 =- case pkgName p1 `compare` pkgName p2 of- LT -> LT- GT -> GT- EQ -> pkgVersion p1 `compare` pkgVersion p2- where (p1,p2) = (sourcePackageId pkg1, sourcePackageId pkg2)-- stack = reverse db_stack_sorted-- match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)-- pkg_map = allPackagesInStack db_stack- broken = map sourcePackageId (brokenPackages pkg_map)-- show_normal PackageDB{ location = db_name, packages = pkg_confs } =- do hPutStrLn stdout (db_name ++ ":")- if null pp_pkgs- then hPutStrLn stdout " (no packages)"- else hPutStrLn stdout $ unlines (map (" " ++) pp_pkgs)- where- -- Sort using instance Ord PackageId- pp_pkgs = map pp_pkg . sortBy (comparing installedPackageId) $ pkg_confs- pp_pkg p- | sourcePackageId p `elem` broken = printf "{%s}" doc- | exposed p = doc- | otherwise = printf "(%s)" doc- where doc | verbosity >= Verbose = printf "%s (%s)" pkg ipid- | otherwise = pkg- where- InstalledPackageId ipid = installedPackageId p- pkg = display (sourcePackageId p)-- show_simple = simplePackageList my_flags . allPackagesInStack-- when (not (null broken) && not simple_output && verbosity /= Silent) $ do- prog <- getProgramName- warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")-- if simple_output then show_simple stack else do--#if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING)- mapM_ show_normal stack-#else- let- show_colour withF db =- mconcat $ map (<#> termText "\n") $- (termText (location db) :- map (termText " " <#>) (map pp_pkg (packages db)))- where- pp_pkg p- | sourcePackageId p `elem` broken = withF Red doc- | exposed p = doc- | otherwise = withF Blue doc- where doc | verbosity >= Verbose- = termText (printf "%s (%s)" pkg ipid)- | otherwise- = termText pkg- where- InstalledPackageId ipid = installedPackageId p- pkg = display (sourcePackageId p)-- is_tty <- hIsTerminalDevice stdout- if not is_tty- then mapM_ show_normal stack- else do tty <- Terminfo.setupTermFromEnv- case Terminfo.getCapability tty withForegroundColor of- Nothing -> mapM_ show_normal stack- Just w -> runTermOutput tty $ mconcat $- map (show_colour w) stack-#endif--simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()-simplePackageList my_flags pkgs = do- let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName- else display- -- Sort using instance Ord PackageId- strs = map showPkg $ sort $ map sourcePackageId pkgs- when (not (null pkgs)) $- hPutStrLn stdout $ concat $ intersperse " " strs--showPackageDot :: Verbosity -> [Flag] -> IO ()-showPackageDot verbosity myflags = do- (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags-- let all_pkgs = allPackagesInStack flag_db_stack- ipix = PackageIndex.fromList all_pkgs-- putStrLn "digraph {"- let quote s = '"':s ++ "\""- mapM_ putStrLn [ quote from ++ " -> " ++ quote to- | p <- all_pkgs,- let from = display (sourcePackageId p),- depid <- depends p,- Just dep <- [PackageIndex.lookupInstalledPackageId ipix depid],- let to = display (sourcePackageId dep)- ]- putStrLn "}"---- -------------------------------------------------------------------------------- Prints the highest (hidden or exposed) version of a package--latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()-latestPackage verbosity my_flags pkgid = do- (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags-- ps <- findPackages flag_db_stack (Id pkgid)- case ps of- [] -> die "no matches"- _ -> show_pkg . maximum . map sourcePackageId $ ps- where- show_pkg pid = hPutStrLn stdout (display pid)---- -------------------------------------------------------------------------------- Describe--describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()-describePackage verbosity my_flags pkgarg expand_pkgroot = do- (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags- dbs <- findPackagesByDB flag_db_stack pkgarg- doDump expand_pkgroot [ (pkg, locationAbsolute db)- | (db, pkgs) <- dbs, pkg <- pkgs ]--dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()-dumpPackages verbosity my_flags expand_pkgroot = do- (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags- doDump expand_pkgroot [ (pkg, locationAbsolute db)- | db <- flag_db_stack, pkg <- packages db ]--doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()-doDump expand_pkgroot pkgs = do- -- fix the encoding to UTF-8, since this is an interchange format- hSetEncoding stdout utf8- putStrLn $- intercalate "---\n"- [ if expand_pkgroot- then showInstalledPackageInfo pkg- else showInstalledPackageInfo pkg ++ pkgrootField- | (pkg, pkgloc) <- pkgs- , let pkgroot = takeDirectory pkgloc- pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ]---- PackageId is can have globVersion for the version-findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]-findPackages db_stack pkgarg- = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg--findPackagesByDB :: PackageDBStack -> PackageArg- -> IO [(PackageDB, [InstalledPackageInfo])]-findPackagesByDB db_stack pkgarg- = case [ (db, matched)- | db <- db_stack,- let matched = filter (pkgarg `matchesPkg`) (packages db),- not (null matched) ] of- [] -> die ("cannot find package " ++ pkg_msg pkgarg)- ps -> return ps- where- pkg_msg (Id pkgid) = display pkgid- pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat--matches :: PackageIdentifier -> PackageIdentifier -> Bool-pid `matches` pid'- = (pkgName pid == pkgName pid')- && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))--realVersion :: PackageIdentifier -> Bool-realVersion pkgid = versionBranch (pkgVersion pkgid) /= []- -- when versionBranch == [], this is a glob--matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool-(Id pid) `matchesPkg` pkg = pid `matches` sourcePackageId pkg-(Substring _ m) `matchesPkg` pkg = m (display (sourcePackageId pkg))---- -------------------------------------------------------------------------------- Field--describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()-describeField verbosity my_flags pkgarg fields expand_pkgroot = do- (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags- fns <- mapM toField fields- ps <- findPackages flag_db_stack pkgarg- mapM_ (selectFields fns) ps- where showFun = if FlagSimpleOutput `elem` my_flags- then showSimpleInstalledPackageInfoField- else showInstalledPackageInfoField- toField f = case showFun f of- Nothing -> die ("unknown field: " ++ f)- Just fn -> return fn- selectFields fns pinfo = mapM_ (\fn->putStrLn (fn pinfo)) fns----- -------------------------------------------------------------------------------- Check: Check consistency of installed packages--checkConsistency :: Verbosity -> [Flag] -> IO ()-checkConsistency verbosity my_flags = do- (db_stack, _, _) <- - getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags- -- check behaves like modify for the purposes of deciding which- -- databases to use, because ordering is important.-- let simple_output = FlagSimpleOutput `elem` my_flags-- let pkgs = allPackagesInStack db_stack-- checkPackage p = do- (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack False True- if null es- then do when (not simple_output) $ do- _ <- reportValidateErrors [] ws "" Nothing- return ()- return []- else do- when (not simple_output) $ do- reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":")- _ <- reportValidateErrors es ws " " Nothing- return ()- return [p]-- broken_pkgs <- concat `fmap` mapM checkPackage pkgs-- let filterOut pkgs1 pkgs2 = filter not_in pkgs2- where not_in p = sourcePackageId p `notElem` all_ps- all_ps = map sourcePackageId pkgs1-- let not_broken_pkgs = filterOut broken_pkgs pkgs- (_, trans_broken_pkgs) = closure [] not_broken_pkgs- all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs-- when (not (null all_broken_pkgs)) $ do- if simple_output- then simplePackageList my_flags all_broken_pkgs- else do- reportError ("\nThe following packages are broken, either because they have a problem\n"++- "listed above, or because they depend on a broken package.")- mapM_ (hPutStrLn stderr . display . sourcePackageId) all_broken_pkgs-- when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)---closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]- -> ([InstalledPackageInfo], [InstalledPackageInfo])-closure pkgs db_stack = go pkgs db_stack- where- go avail not_avail =- case partition (depsAvailable avail) not_avail of- ([], not_avail') -> (avail, not_avail')- (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'-- depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo- -> Bool- depsAvailable pkgs_ok pkg = null dangling- where dangling = filter (`notElem` pids) (depends pkg)- pids = map installedPackageId pkgs_ok-- -- we want mutually recursive groups of package to show up- -- as broken. (#1750)--brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]-brokenPackages pkgs = snd (closure [] pkgs)---- -------------------------------------------------------------------------------- Manipulating package.conf files--type InstalledPackageInfoString = InstalledPackageInfo_ String--convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString-convertPackageInfoOut- (pkgconf@(InstalledPackageInfo { exposedModules = e,- hiddenModules = h })) =- pkgconf{ exposedModules = map display e,- hiddenModules = map display h }--convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo-convertPackageInfoIn- (pkgconf@(InstalledPackageInfo { exposedModules = e,- hiddenModules = h })) =- pkgconf{ exposedModules = map convert e,- hiddenModules = map convert h }- where convert = fromJust . simpleParse--writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()-writeNewConfig verbosity filename ipis = do- when (verbosity >= Normal) $- info "Writing new package config file... "- createDirectoryIfMissing True $ takeDirectory filename- let shown = concat $ intersperse ",\n "- $ map (show . convertPackageInfoOut) ipis- fileContents = "[" ++ shown ++ "\n]"- writeFileUtf8Atomic filename fileContents- `catchIO` \e ->- if isPermissionError e- then die (filename ++ ": you don't have permission to modify this file")- else ioError e- when (verbosity >= Normal) $- infoLn "done."---------------------------------------------------------------------------------- Sanity-check a new package config, and automatically build GHCi libs--- if requested.--type ValidateError = (Force,String)-type ValidateWarning = String--newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) }--instance Functor Validate where- fmap = liftM--instance Applicative Validate where- pure = return- (<*>) = ap--instance Monad Validate where- return a = V $ return (a, [], [])- m >>= k = V $ do- (a, es, ws) <- runValidate m- (b, es', ws') <- runValidate (k a)- return (b,es++es',ws++ws')--verror :: Force -> String -> Validate ()-verror f s = V (return ((),[(f,s)],[]))--vwarn :: String -> Validate ()-vwarn s = V (return ((),[],["Warning: " ++ s]))--liftIO :: IO a -> Validate a-liftIO k = V (k >>= \a -> return (a,[],[]))---- returns False if we should die-reportValidateErrors :: [ValidateError] -> [ValidateWarning]- -> String -> Maybe Force -> IO Bool-reportValidateErrors es ws prefix mb_force = do- mapM_ (warn . (prefix++)) ws- oks <- mapM report es- return (and oks)- where- report (f,s)- | Just force <- mb_force- = if (force >= f)- then do reportError (prefix ++ s ++ " (ignoring)")- return True- else if f < CannotForce- then do reportError (prefix ++ s ++ " (use --force to override)")- return False- else do reportError err- return False- | otherwise = do reportError err- return False- where- err = prefix ++ s--validatePackageConfig :: InstalledPackageInfo- -> Verbosity- -> PackageDBStack- -> Bool -- auto-ghc-libs- -> Bool -- update, or check- -> Force- -> IO ()-validatePackageConfig pkg verbosity db_stack auto_ghci_libs update force = do- (_,es,ws) <- runValidate $ checkPackageConfig pkg verbosity db_stack auto_ghci_libs update- ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)- when (not ok) $ exitWith (ExitFailure 1)--checkPackageConfig :: InstalledPackageInfo- -> Verbosity- -> PackageDBStack- -> Bool -- auto-ghc-libs- -> Bool -- update, or check- -> Validate ()-checkPackageConfig pkg verbosity db_stack auto_ghci_libs update = do- checkInstalledPackageId pkg db_stack update- checkPackageId pkg- checkDuplicates db_stack pkg update- mapM_ (checkDep db_stack) (depends pkg)- checkDuplicateDepends (depends pkg)- mapM_ (checkDir False "import-dirs") (importDirs pkg)- mapM_ (checkDir True "library-dirs") (libraryDirs pkg)- mapM_ (checkDir True "include-dirs") (includeDirs pkg)- mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)- mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)- mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)- checkModules pkg- -- TODO: move jsmod directory structure into single jslib file?- -- mapM_ (checkHSLib verbosity (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)- -- ToDo: check these somehow?- -- extra_libraries :: [String],- -- c_includes :: [String],--checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool - -> Validate ()-checkInstalledPackageId ipi db_stack update = do- let ipid@(InstalledPackageId str) = installedPackageId ipi- when (null str) $ verror CannotForce "missing id field"- let dups = [ p | p <- allPackagesInStack db_stack, - installedPackageId p == ipid ]- when (not update && not (null dups)) $- verror CannotForce $- "package(s) with this id already exist: " ++ - unwords (map (display.packageId) dups)---- When the package name and version are put together, sometimes we can--- end up with a package id that cannot be parsed. This will lead to--- difficulties when the user wants to refer to the package later, so--- we check that the package id can be parsed properly here.-checkPackageId :: InstalledPackageInfo -> Validate ()-checkPackageId ipi =- let str = display (sourcePackageId ipi) in- case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of- [_] -> return ()- [] -> verror CannotForce ("invalid package identifier: " ++ str)- _ -> verror CannotForce ("ambiguous package identifier: " ++ str)--checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()-checkDuplicates db_stack pkg update = do- let- pkgid = sourcePackageId pkg- pkgs = packages (head db_stack)- --- -- Check whether this package id already exists in this DB- --- when (not update && (pkgid `elem` map sourcePackageId pkgs)) $- verror CannotForce $- "package " ++ display pkgid ++ " is already installed"-- let- uncasep = map toLower . display- dups = filter ((== uncasep pkgid) . uncasep) (map sourcePackageId pkgs)-- when (not update && not (null dups)) $ verror ForceAll $- "Package names may be treated case-insensitively in the future.\n"++- "Package " ++ display pkgid ++- " overlaps with: " ++ unwords (map display dups)--checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()-checkDir = checkPath False True-checkFile = checkPath False False-checkDirURL = checkPath True True--checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()-checkPath url_ok is_dir warn_only thisfield d- | url_ok && ("http://" `isPrefixOf` d- || "https://" `isPrefixOf` d) = return ()-- | url_ok- , Just d' <- stripPrefix "file://" d- = checkPath False is_dir warn_only thisfield d'-- -- Note: we don't check for $topdir/${pkgroot} here. We rely on these- -- variables having been expanded already, see mungePackagePaths.-- | isRelative d = verror ForceFiles $- thisfield ++ ": " ++ d ++ " is a relative path which "- ++ "makes no sense (as there is nothing for it to be "- ++ "relative to). You can make paths relative to the "- ++ "package database itself by using ${pkgroot}."- -- relative paths don't make any sense; #4134- | otherwise = do- there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d- when (not there) $- let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "- ++ if is_dir then "directory" else "file"- in- if warn_only - then vwarn msg- else verror ForceFiles msg--checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()-checkDep db_stack pkgid- | pkgid `elem` pkgids = return ()- | otherwise = verror ForceAll ("dependency \"" ++ display pkgid- ++ "\" doesn't exist")- where- all_pkgs = allPackagesInStack db_stack- pkgids = map installedPackageId all_pkgs--checkDuplicateDepends :: [InstalledPackageId] -> Validate ()-checkDuplicateDepends deps- | null dups = return ()- | otherwise = verror ForceAll ("package has duplicate dependencies: " ++- unwords (map display dups))- where- dups = [ p | (p:_:_) <- group (sort deps) ]--checkHSLib :: Verbosity -> [String] -> Bool -> String -> Validate ()-checkHSLib verbosity dirs auto_ghci_libs lib = do- let batch_lib_file = "lib" ++ lib ++ ".a"- filenames = ["lib" ++ lib ++ ".a",- "lib" ++ lib ++ ".p_a",- "lib" ++ lib ++ "-ghc" ++ showVersion ghcVersion ++ ".so",- "lib" ++ lib ++ "-ghc" ++ showVersion ghcVersion ++ ".dylib",- lib ++ "-ghc" ++ showVersion ghcVersion ++ ".dll"]- m <- liftIO $ doesFileExistOnPath filenames dirs- case m of- Nothing -> verror ForceFiles ("cannot find any of " ++ show filenames ++- " on library path")- Just dir -> liftIO $ checkGHCiLib verbosity dir batch_lib_file lib auto_ghci_libs--doesFileExistOnPath :: [FilePath] -> [FilePath] -> IO (Maybe FilePath)-doesFileExistOnPath filenames paths = go fullFilenames- where fullFilenames = [ (path, path </> filename)- | filename <- filenames- , path <- paths ]- go [] = return Nothing- go ((p, fp) : xs) = do b <- doesFileExist fp- if b then return (Just p) else go xs--checkModules :: InstalledPackageInfo -> Validate ()-checkModules pkg = do- mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)- where- findModule modl =- -- there's no interface file for GHC.Prim- unless (modl == fromString "GHC.Prim") $ do- let files = [ toFilePath modl <.> extension- | extension <- ["hi", "p_hi", "dyn_hi" ] ]- m <- liftIO $ doesFileExistOnPath files (importDirs pkg)- when (isNothing m) $- verror ForceFiles ("cannot find any of " ++ show files)--checkGHCiLib :: Verbosity -> String -> String -> String -> Bool -> IO ()-checkGHCiLib verbosity batch_lib_dir batch_lib_file lib auto_build- | auto_build = autoBuildGHCiLib verbosity batch_lib_dir batch_lib_file ghci_lib_file- | otherwise = return ()- where- ghci_lib_file = lib <.> "o"---- automatically build the GHCi version of a batch lib,--- using ld --whole-archive.--autoBuildGHCiLib :: Verbosity -> String -> String -> String -> IO ()-autoBuildGHCiLib verbosity dir batch_file ghci_file = do- let ghci_lib_file = dir ++ '/':ghci_file- batch_lib_file = dir ++ '/':batch_file- when (verbosity >= Normal) $- info ("building GHCi library " ++ ghci_lib_file ++ "...")-#if defined(darwin_HOST_OS)- r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]-#elif defined(mingw32_HOST_OS)- execDir <- getLibDir- r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]-#else- r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]-#endif- when (r /= ExitSuccess) $ exitWith r- when (verbosity >= Normal) $- infoLn (" done.")---- -------------------------------------------------------------------------------- Searching for modules--#if not_yet--findModules :: [FilePath] -> IO [String]-findModules paths =- mms <- mapM searchDir paths- return (concat mms)--searchDir path prefix = do- fs <- getDirectoryEntries path `catchIO` \_ -> return []- searchEntries path prefix fs--searchEntries path prefix [] = return []-searchEntries path prefix (f:fs)- | looks_like_a_module = do- ms <- searchEntries path prefix fs- return (prefix `joinModule` f : ms)- | looks_like_a_component = do- ms <- searchDir (path </> f) (prefix `joinModule` f)- ms' <- searchEntries path prefix fs- return (ms ++ ms')- | otherwise- searchEntries path prefix fs-- where- (base,suffix) = splitFileExt f- looks_like_a_module =- suffix `elem` haskell_suffixes &&- all okInModuleName base- looks_like_a_component =- null suffix && all okInModuleName base--okInModuleName c--#endif---- ------------------------------------------------------------------------------ expanding environment variables in the package configuration--expandEnvVars :: String -> Force -> IO String-expandEnvVars str0 force = go str0 ""- where- go "" acc = return $! reverse acc- go ('$':'{':str) acc | (var, '}':rest) <- break close str- = do value <- lookupEnvVar var- go rest (reverse value ++ acc)- where close c = c == '}' || c == '\n' -- don't span newlines- go (c:str) acc- = go str (c:acc)-- lookupEnvVar :: String -> IO String- lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,- lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them- lookupEnvVar nm =- catchIO (System.Environment.getEnv nm)- (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++- show nm)- return "")---------------------------------------------------------------------------------getProgramName :: IO String-getProgramName = liftM (`withoutSuffix` ".bin") getProgName- where str `withoutSuffix` suff- | suff `isSuffixOf` str = take (length str - length suff) str- | otherwise = str--bye :: String -> IO a-bye s = putStr s >> exitWith ExitSuccess--die :: String -> IO a-die = dieWith 1--dieWith :: Int -> String -> IO a-dieWith ec s = do- prog <- getProgramName- reportError (prog ++ ": " ++ s)- exitWith (ExitFailure ec)--dieOrForceAll :: Force -> String -> IO ()-dieOrForceAll ForceAll s = ignoreError s-dieOrForceAll _other s = dieForcible s--warn :: String -> IO ()-warn = reportError---- send info messages to stdout-infoLn :: String -> IO ()-infoLn = putStrLn--info :: String -> IO ()-info = putStr--ignoreError :: String -> IO ()-ignoreError s = reportError (s ++ " (ignoring)")--reportError :: String -> IO ()-reportError s = do hFlush stdout; hPutStrLn stderr s--dieForcible :: String -> IO ()-dieForcible s = die (s ++ " (use --force to override)")--my_head :: String -> [a] -> a-my_head s [] = error s-my_head _ (x : _) = x--getLibDir :: IO (Maybe String)-getLibDir = return $ Just hasteSysDir---------------------------------------------- Adapted from ghc/compiler/utils/Panic--installSignalHandlers :: IO ()-installSignalHandlers = do- threadid <- myThreadId- let- interrupt = Exception.throwTo threadid- (Exception.ErrorCall "interrupted")- ---#if !defined(mingw32_HOST_OS)- _ <- installHandler sigQUIT (Catch interrupt) Nothing- _ <- installHandler sigINT (Catch interrupt) Nothing- return ()-#else- -- GHC 6.3+ has support for console events on Windows- -- NOTE: running GHCi under a bash shell for some reason requires- -- you to press Ctrl-Break rather than Ctrl-C to provoke- -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know- -- why --SDM 17/12/2004- let sig_handler ControlC = interrupt- sig_handler Break = interrupt- sig_handler _ = return ()-- _ <- installHandler (Catch sig_handler)- return ()-#endif--#if mingw32_HOST_OS || mingw32_TARGET_OS-throwIOIO :: Exception.IOException -> IO a-throwIOIO = Exception.throwIO-#endif--catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-catchIO = Exception.catch--catchError :: IO a -> (String -> IO a) -> IO a-catchError io handler = io `Exception.catch` handler'- where handler' (Exception.ErrorCall err) = handler err--tryIO :: IO a -> IO (Either Exception.IOException a)-tryIO = Exception.try--writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()-writeBinaryFileAtomic targetFile obj =- withFileAtomic targetFile $ \h -> do- hSetBinaryMode h True- B.hPutStr h (Bin.encode obj)--writeFileUtf8Atomic :: FilePath -> String -> IO ()-writeFileUtf8Atomic targetFile content =- withFileAtomic targetFile $ \h -> do- hSetEncoding h utf8- hPutStr h content---- copied from Cabal's Distribution.Simple.Utils, except that we want--- to use text files here, rather than binary files.-withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO ()-withFileAtomic targetFile write_content = do- (newFile, newHandle) <- openNewFile targetDir template- do write_content newHandle- hClose newHandle-#if mingw32_HOST_OS || mingw32_TARGET_OS- renameFile newFile targetFile- -- If the targetFile exists then renameFile will fail- `catchIO` \err -> do- exists <- doesFileExist targetFile- if exists- then do removeFileSafe targetFile- -- Big fat hairy race condition- renameFile newFile targetFile- -- If the removeFile succeeds and the renameFile fails- -- then we've lost the atomic property.- else throwIOIO err-#else- renameFile newFile targetFile-#endif- `Exception.onException` do hClose newHandle- removeFileSafe newFile- where- template = targetName <.> "tmp"- targetDir | null targetDir_ = "."- | otherwise = targetDir_- --TODO: remove this when takeDirectory/splitFileName is fixed- -- to always return a valid dir- (targetDir_,targetName) = splitFileName targetFile--openNewFile :: FilePath -> String -> IO (FilePath, Handle)-openNewFile dir template = do- -- this was added to System.IO in 6.12.1- -- we must use this version because the version below opens the file- -- in binary mode.- openTempFileWithDefaultPermissions dir template---- | The function splits the given string to substrings--- using 'isSearchPathSeparator'.-parseSearchPath :: String -> [FilePath]-parseSearchPath path = split path- where- split :: String -> [String]- split s =- case rest' of- [] -> [chunk]- _:rest -> chunk : split rest- where- chunk =- case chunk' of-#ifdef mingw32_HOST_OS- ('\"':xs@(_:_)) | last xs == '\"' -> init xs-#endif- _ -> chunk'-- (chunk', rest') = break isSearchPathSeparator s--readUTF8File :: FilePath -> IO String-readUTF8File file = do- h <- openFile file ReadMode- -- fix the encoding to UTF-8- hSetEncoding h utf8- hGetContents h---- removeFileSave doesn't throw an exceptions, if the file is already deleted-removeFileSafe :: FilePath -> IO ()-removeFileSafe fn =- removeFile fn `catchIO` \ e ->- when (not $ isDoesNotExistError e) $ ioError e--absolutePath :: FilePath -> IO FilePath-absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory---- | Only global packages may be marked as relocatable!--- May break horribly for general use, only reliable for Haste base packages.-relocate :: [String] -> String -> Sh.Shell ()-relocate packages pkg = do- pi <- Sh.run hastePkgBinary (packages ++ ["describe", pkg]) ""- Sh.run_ hastePkgBinary (packages ++ ["update", "-", "--force", "--global"])- (reloc pi)- where- reloc = unlines . map fixPath . lines-- fixPath s- | isKey "library-dirs: " s = prefix s "library-dirs" importDir- | isKey "import-dirs: " s = prefix s "import-dirs" importDir- | isKey "haddock-interfaces: " s = prefix s "haddock-interfaces" importDir- | isKey "haddock-html: " s = prefix s "haddock-html" importDir- | isKey "include-dirs: " s = "include-dirs: " ++ includeDir- | otherwise = s-- prefix s pfx path = pfx ++ ": " ++ path </> stripPrefix s-- stripPrefix = joinPath . dropWhile (not . isKey pkg) . splitPath-- isKey _ "" =- False- isKey key str =- and $ zipWith (==) key str-- importDir = "${pkgroot}"- includeDir = "${pkgroot}" </> "include"
utils/haste-pkg/HastePkg710.hs view
@@ -38,9 +38,6 @@ import Data.Char ( isSpace, toLower ) import Data.Ord (comparing)-#if __GLASGOW_HASKELL__ < 709-import Control.Applicative (Applicative(..))-#endif import Control.Monad import System.Directory ( doesDirectoryExist, getDirectoryContents, doesFileExist, renameFile, removeFile,@@ -2033,10 +2030,13 @@ -- May break horribly for general use, only reliable for Haste base packages. relocate :: [String] -> String -> Sh.Shell () relocate packages pkg = do- pi <- Sh.run hastePkgBinary (packages ++ ["describe", pkg]) ""- Sh.run_ hastePkgBinary (packages ++ ["update", "-", "--force", "--global"])- (reloc pi)+ pi <- Sh.capture $ Sh.run hastePkgBinary (packages ++ ["describe", pkg])+ Sh.withTempFile Sh.TextMode $ \file h -> do+ Sh.hPutStrLn h (reloc pi)+ Sh.hClose h+ Sh.run hastePkgBinary (relocArgs file) where+ relocArgs file = packages ++ ["update", "--force", "--global", file] reloc = unlines . map fixPath . lines fixPath s
utils/haste-pkg/haste-pkg.hs view
@@ -1,10 +1,6 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ < 709-import qualified HastePkg708 as Real-#else import qualified HastePkg710 as Real-#endif main :: IO () main = Real.main