diff --git a/haste-compiler.cabal b/haste-compiler.cabal --- a/haste-compiler.cabal +++ b/haste-compiler.cabal @@ -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 diff --git a/lib/Foreign.js b/lib/Foreign.js --- a/lib/Foreign.js +++ b/lib/Foreign.js @@ -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) { diff --git a/lib/array.js b/lib/array.js --- a/lib/array.js +++ b/lib/array.js @@ -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; diff --git a/lib/rts.js b/lib/rts.js --- a/lib/rts.js +++ b/lib/rts.js @@ -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") diff --git a/lib/spt.js b/lib/spt.js new file mode 100644 --- /dev/null +++ b/lib/spt.js @@ -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]; +} diff --git a/libraries/haste-lib/src/Haste.hs b/libraries/haste-lib/src/Haste.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/Ajax.hs b/libraries/haste-lib/src/Haste/Ajax.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Ajax.hs +++ /dev/null @@ -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] diff --git a/libraries/haste-lib/src/Haste/App.hs b/libraries/haste-lib/src/Haste/App.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/App.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/App/Client.hs b/libraries/haste-lib/src/Haste/App/Client.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/App/Client.hs +++ /dev/null @@ -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!" diff --git a/libraries/haste-lib/src/Haste/App/Concurrent.hs b/libraries/haste-lib/src/Haste/App/Concurrent.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/App/Concurrent.hs +++ /dev/null @@ -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. 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 diff --git a/libraries/haste-lib/src/Haste/App/Monad.hs b/libraries/haste-lib/src/Haste/App/Monad.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/App/Monad.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/App/Protocol.hs b/libraries/haste-lib/src/Haste/App/Protocol.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/App/Protocol.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/Audio.hs b/libraries/haste-lib/src/Haste/Audio.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Audio.hs +++ /dev/null @@ -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) diff --git a/libraries/haste-lib/src/Haste/Audio/Events.hs b/libraries/haste-lib/src/Haste/Audio/Events.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Audio/Events.hs +++ /dev/null @@ -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 () diff --git a/libraries/haste-lib/src/Haste/Binary.hs b/libraries/haste-lib/src/Haste/Binary.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Binary.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/Binary/Get.hs b/libraries/haste-lib/src/Haste/Binary/Get.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Binary/Get.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/Binary/Put.hs b/libraries/haste-lib/src/Haste/Binary/Put.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Binary/Put.hs +++ /dev/null @@ -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 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 diff --git a/libraries/haste-lib/src/Haste/Binary/Types.hs b/libraries/haste-lib/src/Haste/Binary/Types.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Binary/Types.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/Compiler.hs b/libraries/haste-lib/src/Haste/Compiler.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Compiler.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/Compiler/Flags.hs b/libraries/haste-lib/src/Haste/Compiler/Flags.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Compiler/Flags.hs +++ /dev/null @@ -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 - } diff --git a/libraries/haste-lib/src/Haste/Concurrent.hs b/libraries/haste-lib/src/Haste/Concurrent.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Concurrent.hs +++ /dev/null @@ -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, (!), ( 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. -( Outbox a -> m a -> m () -p 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 diff --git a/libraries/haste-lib/src/Haste/Concurrent/Monad.hs b/libraries/haste-lib/src/Haste/Concurrent/Monad.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Concurrent/Monad.hs +++ /dev/null @@ -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 () diff --git a/libraries/haste-lib/src/Haste/DOM.hs b/libraries/haste-lib/src/Haste/DOM.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/DOM.hs +++ /dev/null @@ -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 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 diff --git a/libraries/haste-lib/src/Haste/DOM/Core.hs b/libraries/haste-lib/src/Haste/DOM/Core.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/DOM/Core.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/DOM/JSString.hs b/libraries/haste-lib/src/Haste/DOM/JSString.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/DOM/JSString.hs +++ /dev/null @@ -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 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);})" diff --git a/libraries/haste-lib/src/Haste/Events.hs b/libraries/haste-lib/src/Haste/Events.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Events.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/Events/BasicEvents.hs b/libraries/haste-lib/src/Haste/Events/BasicEvents.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Events/BasicEvents.hs +++ /dev/null @@ -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 () diff --git a/libraries/haste-lib/src/Haste/Events/Core.hs b/libraries/haste-lib/src/Haste/Events/Core.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Events/Core.hs +++ /dev/null @@ -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]);})" diff --git a/libraries/haste-lib/src/Haste/Events/KeyEvents.hs b/libraries/haste-lib/src/Haste/Events/KeyEvents.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Events/KeyEvents.hs +++ /dev/null @@ -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" diff --git a/libraries/haste-lib/src/Haste/Events/MouseEvents.hs b/libraries/haste-lib/src/Haste/Events/MouseEvents.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Events/MouseEvents.hs +++ /dev/null @@ -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" diff --git a/libraries/haste-lib/src/Haste/Events/TouchEvents.hs b/libraries/haste-lib/src/Haste/Events/TouchEvents.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Events/TouchEvents.hs +++ /dev/null @@ -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];})" diff --git a/libraries/haste-lib/src/Haste/Foreign.hs b/libraries/haste-lib/src/Haste/Foreign.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Foreign.hs +++ /dev/null @@ -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" diff --git a/libraries/haste-lib/src/Haste/Graphics/AnimationFrame.hs b/libraries/haste-lib/src/Haste/Graphics/AnimationFrame.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Graphics/AnimationFrame.hs +++ /dev/null @@ -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" diff --git a/libraries/haste-lib/src/Haste/Graphics/Canvas.hs b/libraries/haste-lib/src/Haste/Graphics/Canvas.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Graphics/Canvas.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/Hash.hs b/libraries/haste-lib/src/Haste/Hash.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Hash.hs +++ /dev/null @@ -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);})" diff --git a/libraries/haste-lib/src/Haste/JSON.hs b/libraries/haste-lib/src/Haste/JSON.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/JSON.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/JSString.hs b/libraries/haste-lib/src/Haste/JSString.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/JSString.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/LocalStorage.hs b/libraries/haste-lib/src/Haste/LocalStorage.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/LocalStorage.hs +++ /dev/null @@ -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);})" diff --git a/libraries/haste-lib/src/Haste/Object.hs b/libraries/haste-lib/src/Haste/Object.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Object.hs +++ /dev/null @@ -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;\ - }\ - })" diff --git a/libraries/haste-lib/src/Haste/Parsing.hs b/libraries/haste-lib/src/Haste/Parsing.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Parsing.hs +++ /dev/null @@ -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, ()) diff --git a/libraries/haste-lib/src/Haste/Performance.hs b/libraries/haste-lib/src/Haste/Performance.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Performance.hs +++ /dev/null @@ -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;})" diff --git a/libraries/haste-lib/src/Haste/Random.hs b/libraries/haste-lib/src/Haste/Random.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Random.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/Serialize.hs b/libraries/haste-lib/src/Haste/Serialize.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Serialize.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-lib/src/Haste/Timer.hs b/libraries/haste-lib/src/Haste/Timer.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/Timer.hs +++ /dev/null @@ -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);})" diff --git a/libraries/haste-lib/src/Haste/WebSockets.hs b/libraries/haste-lib/src/Haste/WebSockets.hs deleted file mode 100644 --- a/libraries/haste-lib/src/Haste/WebSockets.hs +++ /dev/null @@ -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);})" diff --git a/libraries/haste-prim/src/Haste/Prim.hs b/libraries/haste-prim/src/Haste/Prim.hs deleted file mode 100644 --- a/libraries/haste-prim/src/Haste/Prim.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-prim/src/Haste/Prim/Any.hs b/libraries/haste-prim/src/Haste/Prim/Any.hs deleted file mode 100644 --- a/libraries/haste-prim/src/Haste/Prim/Any.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-prim/src/Haste/Prim/Foreign.hs b/libraries/haste-prim/src/Haste/Prim/Foreign.hs deleted file mode 100644 --- a/libraries/haste-prim/src/Haste/Prim/Foreign.hs +++ /dev/null @@ -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 diff --git a/libraries/haste-prim/src/Haste/Prim/JSType.hs b/libraries/haste-prim/src/Haste/Prim/JSType.hs deleted file mode 100644 --- a/libraries/haste-prim/src/Haste/Prim/JSType.hs +++ /dev/null @@ -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 diff --git a/src/Haste/AST/Binary.hs b/src/Haste/AST/Binary.hs --- a/src/Haste/AST/Binary.hs +++ b/src/Haste/AST/Binary.hs @@ -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) = diff --git a/src/Haste/AST/Constructors.hs b/src/Haste/AST/Constructors.hs --- a/src/Haste/AST/Constructors.hs +++ b/src/Haste/AST/Constructors.hs @@ -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 diff --git a/src/Haste/AST/Optimize.hs b/src/Haste/AST/Optimize.hs --- a/src/Haste/AST/Optimize.hs +++ b/src/Haste/AST/Optimize.hs @@ -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 diff --git a/src/Haste/AST/PP.hs b/src/Haste/AST/PP.hs --- a/src/Haste/AST/PP.hs +++ b/src/Haste/AST/PP.hs @@ -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 diff --git a/src/Haste/AST/Print.hs b/src/Haste/AST/Print.hs --- a/src/Haste/AST/Print.hs +++ b/src/Haste/AST/Print.hs @@ -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 diff --git a/src/Haste/AST/Syntax.hs b/src/Haste/AST/Syntax.hs --- a/src/Haste/AST/Syntax.hs +++ b/src/Haste/AST/Syntax.hs @@ -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 diff --git a/src/Haste/CodeGen.hs b/src/Haste/CodeGen.hs --- a/src/Haste/CodeGen.hs +++ b/src/Haste/CodeGen.hs @@ -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. diff --git a/src/Haste/Config.hs b/src/Haste/Config.hs --- a/src/Haste/Config.hs +++ b/src/Haste/Config.hs @@ -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 diff --git a/src/Haste/Environment.hs b/src/Haste/Environment.hs --- a/src/Haste/Environment.hs +++ b/src/Haste/Environment.hs @@ -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 diff --git a/src/Haste/Linker.hs b/src/Haste/Linker.hs --- a/src/Haste/Linker.hs +++ b/src/Haste/Linker.hs @@ -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 diff --git a/src/Haste/Module.hs b/src/Haste/Module.hs --- a/src/Haste/Module.hs +++ b/src/Haste/Module.hs @@ -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 diff --git a/src/Haste/Monad.hs b/src/Haste/Monad.hs --- a/src/Haste/Monad.hs +++ b/src/Haste/Monad.hs @@ -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 diff --git a/src/Haste/PrimOps.hs b/src/Haste/PrimOps.hs --- a/src/Haste/PrimOps.hs +++ b/src/Haste/PrimOps.hs @@ -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 diff --git a/src/haste-boot.hs b/src/haste-boot.hs --- a/src/haste-boot.hs +++ b/src/haste-boot.hs @@ -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] diff --git a/src/hastec.hs b/src/hastec.hs --- a/src/hastec.hs +++ b/src/hastec.hs @@ -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 @@ "", "", filename , "", "", + "", "", ""] @@ -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!" diff --git a/utils/haste-pkg/HastePkg708.hs b/utils/haste-pkg/HastePkg708.hs deleted file mode 100644 --- a/utils/haste-pkg/HastePkg708.hs +++ /dev/null @@ -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" diff --git a/utils/haste-pkg/HastePkg710.hs b/utils/haste-pkg/HastePkg710.hs --- a/utils/haste-pkg/HastePkg710.hs +++ b/utils/haste-pkg/HastePkg710.hs @@ -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 diff --git a/utils/haste-pkg/haste-pkg.hs b/utils/haste-pkg/haste-pkg.hs --- a/utils/haste-pkg/haste-pkg.hs +++ b/utils/haste-pkg/haste-pkg.hs @@ -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