diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, The University of Kansas + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Andy Gill nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Language/Sunroof.hs b/Language/Sunroof.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof.hs @@ -0,0 +1,202 @@ + +-- | Sunroof provides a way to express Javascript computations in +-- Haskell. The computations can be expressed using the 'JS' monad. +-- +-- There are ready to use API bindings for frequently used +-- Javascript: +-- +-- * 'Language.Sunroof.JS.Browser' - Bindings of the standard browser APIs. +-- +-- * 'Language.Sunroof.JS.Canvas' - Bindings of the HTML5 canvas element API. +-- +-- * 'Language.Sunroof.JS.JQuery' - Bindings of some JQuery methods. +-- +-- * 'Language.Sunroof.JS.Date' - Bindings of the standard data API. +-- +-- It also provides an abstraction over Javascripts (not existing) threading +-- model. Cooperative multithreading can be emulated using the Sunroof +-- abstractions ('forkJS', 'yield', 'loop'). Equivalents of well-known +-- Haskell concurrency abstractions like 'Control.Concurrent.MVar' +-- or 'Control.Concurrent.Chan' are also provided on Javascript level +-- through 'JSMVar' and 'JSChan'. +-- +-- Due to the threading abstraction there are two kinds of computations. +-- They are indicated by the first type parameter of 'JS' (a 'T' value). +-- Normal Javascript computations that can be assumed to terminate and +-- that may deliver a result value are written in the 'JSA' monad. While +-- possibly blocking computations (those that involve threading operations) +-- are written in the 'JSB' monad. +-- +-- As the computations are expressed in Haskell, they have a functional +-- nature. It is possible to change the attribute values of objects using +-- ':=' and 'Language.Sunroof.Types.#': +-- +-- > o # att := val +-- +-- If a top-level mutable variable is needed, use the 'JSRef' abstraction. +-- It is comparable to 'Data.IORef.IORef'. +module Language.Sunroof + ( + -- * Notes + -- | It is advised to use Sunroof with the following language extensions: + -- + -- * @OverloadedStrings@ - Enables using literal strings for attribute + -- names and Javascript strings. + -- + -- * @DataKinds@ - Enables using @JS A@ or @JS B@ instead of @JSA@ and @JSB@. + -- This extension is not essential. + -- + + -- * Sunroof Compiler + sunroofCompileJSA + , sunroofCompileJSB + , CompilerOpts(..) + -- * Classes + , Sunroof(..), SunroofValue(..), SunroofArgument(..) + , JSTuple(..) + , SunroofKey(..) + -- * Types + , Type(..) + , T(..), ThreadProxy(..) + , SunroofThread(..) + , JS(..), JSA, JSB + , JSFunction + , JSContinuation + , JSSelector + -- * DSL Primitives and Utilties + , done, liftJS + , function, continuation + , apply, ($$), goto + , cast + , (#) + , attr + , fun, invoke, new + , evaluate, value + , switch + , nullJS + , label, index + , (!) + , callcc + , comment + , delete + -- * Concurrency Primitives + , forkJS + , threadDelay + , yield + -- * Basic JS types + -- ** JavaScript Object + , JSObject, this, object + -- ** Boolean + , JSBool + -- ** Numbers + , JSNumber, int + -- ** Strings + , JSString, string + -- ** Array + , JSArray + , array, newArray + , length' + , lookup' + , insert' + , shift, unshift + , pop, push + , forEach + , empty + -- ** References + , JSRef + , newJSRef + , readJSRef + , writeJSRef + , modifyJSRef + -- ** Channnels + , JSChan + , newChan + , writeChan, readChan + -- ** Thread-safe Mutable Variables + , JSMVar + , newMVar + , newEmptyMVar + , takeMVar, putMVar + -- * DSL Utilties + , loop + , fixJS + ) where + +import Language.Sunroof.JavaScript ( Type(..) ) + +import Language.Sunroof.Classes + ( Sunroof(..), SunroofValue(..), SunroofArgument(..) ) + +import Language.Sunroof.Types + ( T(..), ThreadProxy(..) + , SunroofThread(..) + , JS(..), JSA, JSB + , done, liftJS + , JSFunction + , JSContinuation + , function, continuation + , callcc + , apply, ($$), goto + , cast + , (#) + , attr + , fun, invoke, new + , evaluate, value + , switch + , nullJS + , delete + , JSTuple(..) + , SunroofKey(..) + ) + +import Language.Sunroof.Compiler + ( sunroofCompileJSA + , sunroofCompileJSB + , CompilerOpts(..) ) + +import Language.Sunroof.Selector + ( JSSelector + , label, index + , (!) ) + +import Language.Sunroof.Concurrent + ( loop + , forkJS + , threadDelay + , yield ) + +import Language.Sunroof.JS.Ref + ( JSRef + , newJSRef + , readJSRef + , writeJSRef + , modifyJSRef ) + +import Language.Sunroof.JS.Bool ( JSBool ) +import Language.Sunroof.JS.Object ( JSObject, object, this ) +import Language.Sunroof.JS.Number ( JSNumber, int ) +import Language.Sunroof.JS.String ( JSString, string ) + +import Language.Sunroof.JS.Array + ( JSArray + , array, newArray + , length' + , lookup' + , insert' + , forEach + , shift, unshift + , pop, push + , empty ) + +import Language.Sunroof.JS.Chan + ( JSChan + , newChan + , writeChan, readChan ) + +import Language.Sunroof.JS.MVar + ( JSMVar + , newMVar, newEmptyMVar + , takeMVar, putMVar ) + +import Language.Sunroof.Utils + ( comment, fixJS ) diff --git a/Language/Sunroof/Classes.hs b/Language/Sunroof/Classes.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/Classes.hs @@ -0,0 +1,220 @@ + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Provides the central type classes used by Sunroof. +module Language.Sunroof.Classes + ( Sunroof(..) + , SunroofValue(..) + , SunroofArgument(..) + , UniqM(..), Uniq + , mkVar, jsVar + ) where + +import Control.Monad ( ap, liftM2, liftM3, liftM4, liftM5 ) + +import Data.Proxy ( Proxy(Proxy) ) + +import Language.Sunroof.JavaScript ( Expr, E(Var), Type(Base,Unit), literal ) + +-- ------------------------------------------------------------- +-- UniqM Type Class +-- ------------------------------------------------------------- + +-- | Used for unique number generation. +type Uniq = Int + +-- | Implemented if a monad supports unique number generation. +class Monad m => UniqM m where + -- | Generate a unique number. + uniqM :: m Uniq + +-- | Creates a Javascript variable of any Sunroof type. +mkVar :: Sunroof a => Uniq -> a +mkVar = box . Var . ("v" ++) . show + +-- | Create a unique Javascript variable of any Sunroof type. +jsVar :: (Sunroof a, UniqM m) => m a +jsVar = uniqM >>= return . mkVar + +-- ------------------------------------------------------------- +-- Sunroof Type Class +-- ------------------------------------------------------------- + +-- | Central type class of Sunroof. Every type that can be translated +-- into Javascript with Sunroof has to implement this type class. +class {-Show a =>-} Sunroof a where + -- | Create a Sunroof value from a plain Javascript expression. + box :: Expr -> a + -- | Reveal the plain Javascript expression that represents this Sunroof value. + unbox :: a -> Expr + + -- Create a string representation of this Sunroof value. + -- The created representation has to be executable Javascript. + -- The default implentation uses 'show'. This + -- function is needed, because unit is a Sunroof value. + --showVar :: a -> String + --showVar = show + + -- | Returns the type of Javascript expression this Sunroof value + -- represents. The default implementation returns 'Base' as type. + typeOf :: Proxy a -> Type + typeOf _ = Base + +-- | Unit is a Sunroof value. It can be viewed as a representation +-- of @null@ or @void@. +instance Sunroof () where +-- showVar _ = "" + box _ = () + unbox () = literal "null" + typeOf _ = Unit + +-- ------------------------------------------------------------- +-- SunroofValue Type Class +-- ------------------------------------------------------------- + +-- | All Haskell values that have a Sunroof representation +-- implement this class. +class SunroofValue a where + -- | The Sunroot type that is equivalent to the implementing Haskell type. + type ValueOf a :: * + -- | Convert the Haskell value to its Sunroof equivalent. + js :: a -> ValueOf a + +-- | Unit is unit. +instance SunroofValue () where + type ValueOf () = () + js () = () + +-- ------------------------------------------------------------- +-- SunroofArgument Type Class +-- ------------------------------------------------------------- + +-- | Everything that can be used as argument to a function is Javascript/Sunroof. +class SunroofArgument args where + -- | Turn the argument into a list of expressions. + jsArgs :: args -> [Expr] + -- | Create a list of fresh variables for the arguments. + jsValue :: (UniqM m) => m args + -- | Get the type of the argument values. + typesOf :: Proxy args -> [Type] + +-- | Every 'Sunroof' value can be an argument to a function. +instance Sunroof a => SunroofArgument a where + jsArgs a = [unbox a] + jsValue = jsVar + typesOf p = [typeOf p] + +-- | Unit is the empty argument list. +instance SunroofArgument () where + jsArgs _ = [] + jsValue = return () + typesOf _ = [] + +-- | Two arguments. +instance (Sunroof a, Sunroof b) => SunroofArgument (a,b) where + jsArgs ~(a,b) = [unbox a, unbox b] + jsValue = liftM2 (,) jsVar jsVar + typesOf Proxy = [typeOf (Proxy :: Proxy a),typeOf (Proxy :: Proxy b)] + +-- | Three arguments. +instance (Sunroof a, Sunroof b, Sunroof c) => SunroofArgument (a,b,c) where + jsArgs ~(a,b,c) = [unbox a, unbox b, unbox c] + jsValue = liftM3 (,,) jsVar jsVar jsVar + typesOf Proxy = [typeOf (Proxy :: Proxy a) + ,typeOf (Proxy :: Proxy b) + ,typeOf (Proxy :: Proxy c) + ] + +-- | Four arguments. +instance (Sunroof a, Sunroof b, Sunroof c, Sunroof d) => SunroofArgument (a,b,c,d) where + jsArgs ~(a,b,c,d) = [unbox a, unbox b, unbox c, unbox d] + jsValue = liftM4 (,,,) jsVar jsVar jsVar jsVar + typesOf Proxy = [typeOf (Proxy :: Proxy a) + ,typeOf (Proxy :: Proxy b) + ,typeOf (Proxy :: Proxy c) + ,typeOf (Proxy :: Proxy d) + ] + +-- | Five arguments. +instance (Sunroof a, Sunroof b, Sunroof c, Sunroof d, Sunroof e) => SunroofArgument (a,b,c,d,e) where + jsArgs ~(a,b,c,d,e) = [unbox a, unbox b, unbox c, unbox d, unbox e] + jsValue = liftM5 (,,,,) jsVar jsVar jsVar jsVar jsVar + typesOf Proxy = [typeOf (Proxy :: Proxy a) + ,typeOf (Proxy :: Proxy b) + ,typeOf (Proxy :: Proxy c) + ,typeOf (Proxy :: Proxy d) + ,typeOf (Proxy :: Proxy e) + ] + +-- | Six arguments. +instance (Sunroof a, Sunroof b, Sunroof c, Sunroof d, Sunroof e, Sunroof f) => SunroofArgument (a,b,c,d,e,f) where + jsArgs ~(a,b,c,d,e,f) = [unbox a, unbox b, unbox c, unbox d, unbox e, unbox f] + jsValue = return (,,,,,) `ap` jsVar `ap` jsVar `ap` jsVar `ap` jsVar `ap` jsVar `ap` jsVar + typesOf Proxy = [typeOf (Proxy :: Proxy a) + ,typeOf (Proxy :: Proxy b) + ,typeOf (Proxy :: Proxy c) + ,typeOf (Proxy :: Proxy d) + ,typeOf (Proxy :: Proxy e) + ,typeOf (Proxy :: Proxy f) + ] + +-- | Seven arguments. +instance (Sunroof a, Sunroof b, Sunroof c, Sunroof d, Sunroof e, Sunroof f, Sunroof g) => SunroofArgument (a,b,c,d,e,f,g) where + jsArgs ~(a,b,c,d,e,f,g) = [unbox a, unbox b, unbox c, unbox d, unbox e, unbox f, unbox g] + jsValue = return (,,,,,,) `ap` jsVar `ap` jsVar `ap` jsVar `ap` jsVar `ap` jsVar `ap` jsVar `ap` jsVar + typesOf Proxy = [typeOf (Proxy :: Proxy a) + ,typeOf (Proxy :: Proxy b) + ,typeOf (Proxy :: Proxy c) + ,typeOf (Proxy :: Proxy d) + ,typeOf (Proxy :: Proxy e) + ,typeOf (Proxy :: Proxy f) + ,typeOf (Proxy :: Proxy g) + ] + +-- | Eight arguments. +instance (Sunroof a, Sunroof b, Sunroof c, Sunroof d, Sunroof e, Sunroof f, Sunroof g, Sunroof h) => SunroofArgument (a,b,c,d,e,f,g,h) where + jsArgs ~(a,b,c,d,e,f,g,h) = [unbox a, unbox b, unbox c, unbox d, unbox e, unbox f, unbox g, unbox h] + jsValue = return (,,,,,,,) `ap` jsVar `ap` jsVar `ap` jsVar `ap` jsVar `ap` jsVar `ap` jsVar `ap` jsVar `ap` jsVar + typesOf Proxy = [typeOf (Proxy :: Proxy a) + ,typeOf (Proxy :: Proxy b) + ,typeOf (Proxy :: Proxy c) + ,typeOf (Proxy :: Proxy d) + ,typeOf (Proxy :: Proxy e) + ,typeOf (Proxy :: Proxy f) + ,typeOf (Proxy :: Proxy g) + ,typeOf (Proxy :: Proxy h) + ] + +-- | Nine arguments. +instance (Sunroof a, Sunroof b, Sunroof c, Sunroof d, Sunroof e, Sunroof f, Sunroof g, Sunroof h, Sunroof i) => SunroofArgument (a,b,c,d,e,f,g,h,i) where + jsArgs ~(a,b,c,d,e,f,g,h,i) = [unbox a, unbox b, unbox c, unbox d, unbox e, unbox f, unbox g, unbox h, unbox i] + jsValue = return (,,,,,,,,) + `ap` jsVar + `ap` jsVar + `ap` jsVar + `ap` jsVar + `ap` jsVar + `ap` jsVar + `ap` jsVar + `ap` jsVar + `ap` jsVar + typesOf Proxy = [typeOf (Proxy :: Proxy a) + ,typeOf (Proxy :: Proxy b) + ,typeOf (Proxy :: Proxy c) + ,typeOf (Proxy :: Proxy d) + ,typeOf (Proxy :: Proxy e) + ,typeOf (Proxy :: Proxy f) + ,typeOf (Proxy :: Proxy g) + ,typeOf (Proxy :: Proxy h) + ,typeOf (Proxy :: Proxy i) + ] + + + + + + diff --git a/Language/Sunroof/Compiler.hs b/Language/Sunroof/Compiler.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/Compiler.hs @@ -0,0 +1,422 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Provides the Sunroof to Javascript compiler. +module Language.Sunroof.Compiler + ( sunroofCompileJSA + , sunroofCompileJSB + , compileJS + , CompilerOpts(..) + ) where + +import Control.Monad.Operational +import Control.Monad.State +import Control.Monad.Reader + +import Data.Reify +import Data.Graph +import Data.Maybe +import Data.Proxy ( Proxy(..) ) +import qualified Data.Map as Map +import Data.Default + +import Language.Sunroof.Types + ( T(..) + , JS(..), JSI(..) + , SunroofThread(..) + , ThreadProxy(..) + , single, apply, unJS, nullJS + , continuation, goto ) +import Language.Sunroof.JavaScript +import Language.Sunroof.Classes + ( Sunroof(..), SunroofArgument(..) + , UniqM(..), Uniq ) +import Language.Sunroof.Selector ( unboxSelector, (!) ) +import Language.Sunroof.Internal ( proxyOf ) + +import Language.Sunroof.JS.Object ( JSObject ) + +-- ------------------------------------------------------------- +-- Compiler +-- ------------------------------------------------------------- + +-- | Options to setup the compiler. +data CompilerOpts = CompilerOpts + { co_on :: Bool + -- ^ Do we reify to capture Haskell-level lets / CSEs? + , co_cse :: Bool + -- ^ Do we also capture non-reified CSE, using Value Numbering? + , co_const :: Bool + -- ^ Do we constant fold? + , co_verbose :: Int + -- ^ How verbose is the compiler when running? standard 0 - 3 scale + , co_compress :: Bool + -- ^ Does the compiler output code without whitespace and layout? default == False + } + deriving Show + +-- | Default compiler options. +instance Default CompilerOpts where + def = CompilerOpts True False False 0 False + +-- | The sunroof compiler compiles an effect that returns a Sunroof/JavaScript +-- value into a JavaScript program. An example invocation is +-- +-- @ +-- GHCi> import Language.Sunroof +-- GHCi> import Language.Sunroof.JS.Browser +-- GHCi> import Data.Default +-- GHCi> txt <- sunroofCompileJSA def \"main\" $ do alert(js \"Hello\"); +-- GHCi> putStrLn txt +-- var main = (function() { +-- alert(\"Hello\"); +-- })(); +-- @ +-- +-- (The extra function and application are intentional and are a common JavaScript +-- trick to circumvent scoping issues.) +-- +-- To generate a function, not just an effect, you can use the 'function' combinator. +-- +-- @ +-- GHCi> txt <- sunroofCompileJSA def \"main\" $ do +-- function $ \\ n -> do +-- return (n * (n :: JSNumber)) +-- GHCi> putStrLn txt +-- var main = (function() { +-- var v1 = function(v0) { +-- return v0*v0; +-- }; +-- return v1; +-- })(); +-- @ +-- +-- Now @main@ in JavaScript is bound to the square function. +-- +sunroofCompileJSA :: (Sunroof a) => CompilerOpts -> String -> JS A a -> IO String +sunroofCompileJSA opts fName f = do + (stmts,_) <- compileJS opts 0 (single . JS_Return) f + return $ showStmt $ mkVarStmt fName $ scopeForEffect stmts + +-- | Compiles code using the blocking threading model. +-- Usage is the same as for 'sunroofCompileJSA'. +sunroofCompileJSB :: CompilerOpts -> String -> JS B () -> IO String +sunroofCompileJSB opts fName f = sunroofCompileJSA opts fName $ do + k <- continuation (\ () -> f) + goto k () :: JS A () + +-- | Extracts the 'Control.Monad.Operational.Program' from the given +-- Javascript computation using the given continuation closer. +extractProgramJS :: (a -> JS t ()) -> JS t a -> Program (JSI t) () +extractProgramJS k m = unJS (m >>= k) return + +-- | Compile a Javascript computation (using the given continuation closer) +-- into basic Javascript statements. Also return the next fresh +-- unique. This function should only be used if you know what your doing! +compileJS :: CompilerOpts -> Uniq -> (a -> JS t ()) -> JS t a -> IO ([Stmt], Uniq) +compileJS opts uq k m = runStateT (runReaderT (compile $ extractProgramJS k m) opts) uq + +compile :: Program (JSI t) () -> CompM [Stmt] +compile = eval . view + -- since the type Program is abstract (for efficiency), + -- we have to apply the view function first, + -- to get something we can pattern match on + where + eval :: ProgramView (JSI t) () -> CompM [Stmt] + -- Return *will* be (), because of the normalization to CPS. + eval (Return ()) = return [] + + -- These are in the same order as the constructors. + + eval (JS_Eval e :>>= g) = do + compileBind (unbox e) g + + eval (JS_Assign sel a obj :>>= g) = do + -- note, this is where we need to optimize/CSE the a value. + -- TODO: this constructor should return unit, not the updated value + (stmts0,val) <- compileExpr (unbox a) + --let ty = typeOf (proxyOf a) + stmts1 <- compile (g ()) + return ( stmts0 ++ [AssignStmt (DotRhs (unbox obj) (unboxSelector sel)) val] ++ stmts1) + + eval (JS_Select sel obj :>>= g) = do + compileBind (Apply (ExprE (Var "[]")) [ExprE $ unbox obj, ExprE $ unboxSelector sel]) g + + eval (JS_Delete sel obj :>>= g) = do + let ty = typeOf (proxyOf (obj ! sel)) + stmts1 <- compile (g ()) + return (DeleteStmt (Dot (ExprE $ unbox obj) (ExprE $ unboxSelector sel) ty) : stmts1) + + -- Return returns Haskell type JS A (), because there is nothing after a return. + -- We ignore everything after a return. + eval (JS_Return e :>>= _) = do + let ty = typeOf (proxyOf e) + case ty of + Unit -> return [] -- nothing to return + _ -> do + (stmts0,val) <- compileExpr (unbox e) + return ( stmts0 ++ [ ReturnStmt val]) + + -- All assignments to () are not done. + eval (JS_Assign_ _ a :>>= g) | typeOf (proxyOf a) == Unit = do + stmts1 <- compile (g ()) + return stmts1 + + eval (JS_Assign_ v a :>>= g) = do + (stmts0,val) <- compileExpr (unbox a) + stmts1 <- compile (g ()) + return ( stmts0 ++ [AssignStmt (VarRhs v) val] ++ stmts1) + + eval (JS_Invoke args fn :>>= g) = do + compileBind (Apply (ExprE $ unbox fn) (map ExprE (jsArgs args))) g + + eval (JS_Function f :>>= g) = do + e <- compileFunction f + compileBind e g + + eval (JS_Continuation f :>>= g) = do + e <- compileContinuation f + compileBind e g + + eval (JS_Branch b c1 c2 :>>= g) = compileBranch b c1 c2 g + + eval (JS_Fix h1 :>>= g) = compileFix h1 g + + eval (JS_Comment msg :>>= g) = do + rest <- compile (g ()) + return $ CommentStmt msg : rest + +compileBind :: forall a t . (Sunroof a) + => Expr + -> (a -> Program (JSI t) ()) + -> CompM [Stmt] +compileBind e m2 = do + a <- newVar + (stmts0,val) <- compileExpr e + stmts1 <- compile (m2 (var a)) + let isUnit = typeOf (Proxy::Proxy a) == Unit + valIsTriv = case val of + Var {} -> True + Lit {} -> True + _ -> False + case () of + _ | isUnit && null stmts0 && valIsTriv + -> return stmts1 + | isUnit -> return (stmts0 ++ [ExprStmt val] ++ stmts1 ) + | otherwise -> return (stmts0 ++ [mkVarStmt a val] ++ stmts1 ) + +compileBranch_A :: forall a bool t . (Sunroof a, Sunroof bool) + => bool -> JS t a -> JS t a -> (a -> Program (JSI t) ()) -> CompM [Stmt] +compileBranch_A b c1 c2 k = do + -- TODO: newVar should take a Id, or return an ID. varId is a hack. + res <- newVar + (src0, res0) <- compileExpr (unbox b) + src1 <- compile $ extractProgramJS (single . JS_Assign_ res) c1 + src2 <- compile $ extractProgramJS (single . JS_Assign_ res) c2 + rest <- compile (k (var res)) + return (src0 ++ [ IfStmt res0 src1 src2 ] ++ rest) + +compileBranch_B :: forall a bool t . (Sunroof bool, SunroofArgument a, SunroofThread t) + => bool -> JS t a -> JS t a -> (a -> Program (JSI t) ()) -> CompM [Stmt] +compileBranch_B b c1 c2 k = do + fn_e <- compileContinuation (\ a -> blockableJS $ JS $ \ k2 -> k a >>= k2) + -- TODO: newVar should take a Id, or return an ID. varId is a hack. + fn <- newVar + (src0, res0) <- compileExpr (unbox b) + src1 <- compile $ extractProgramJS (apply (var fn)) c1 + src2 <- compile $ extractProgramJS (apply (var fn)) c2 + return ( [mkVarStmt fn fn_e] ++ src0 ++ [ IfStmt res0 src1 src2 ]) + +compileBranch :: forall a bool t . (SunroofThread t, Sunroof bool, Sunroof a, SunroofArgument a) + => bool -> JS t a -> JS t a -> (a -> Program (JSI t) ()) -> CompM [Stmt] +compileBranch b c1 c2 k = + case evalStyle (ThreadProxy :: ThreadProxy t) of + A -> compileBranch_A b c1 c2 k + B -> compileBranch_B b c1 c2 k + +compileFix :: forall a t . (SunroofArgument a) + => (a -> JS A a) -> (a -> Program (JSI t) ()) -> CompM [Stmt] +compileFix h1 k = do + -- invent the scoped named variables + args <- jsValue + -- set up the variables with null + let initial = + [ mkVarStmt v (unbox nullJS) + | Var v <- jsArgs args + ] + + body <- compile (unJS (h1 args) (\ res -> do + when (length (jsArgs args) /= length (jsArgs res)) $ + error "fatal error in mdo compile" + singleton $ JS_Comment + $ "tie the knot" + sequence_ [ singleton $ JS_Assign_ v (box $ e :: JSObject) + | (Var v, e) <- jsArgs args `zip` jsArgs res + ])) + + rest <- compile (k args) + + return $ + [ CommentStmt "set up recusive values" ] ++ + initial ++ + [ CommentStmt "body of the mdo-style rec" ] ++ + body ++ + [ CommentStmt "and proceed with the rest of the program"] ++ + rest + +{- +unJS :: JS t a -> (a -> Program (JSI t) ()) -> Program (JSI t) () + :: (a -> JS t ()) -> JS t a -> Program (JSI t) () +extractProgramJS k m = unJS (m >>= k) return + + + +-} + +-- var v = + + +compileFunction :: forall a b . (SunroofArgument a, Sunroof b) + => (a -> JS A b) + -> CompM Expr +compileFunction m2 = do + (arg :: a) <- jsValue + fStmts <- compile $ extractProgramJS (\ a -> JS $ \ k -> singleton (JS_Return a) >>= k) (m2 arg) + return $ Function (map varIdE $ jsArgs arg) fStmts + +compileContinuation :: forall a b . (SunroofArgument a, Sunroof b) + => (a -> JS B b) + -> CompM Expr +compileContinuation m2 = do + (arg :: a) <- jsValue + fStmts <- compile $ extractProgramJS (\ _ -> JS $ \ k -> k ()) (m2 arg) + return $ Function (map varIdE $ jsArgs arg) fStmts + + +compileExpr :: Expr -> CompM ([Stmt], Expr) +compileExpr e = do + opts <- ask + optExpr opts e + + +data Inst i e = Inst (i e) + | Copy e -- an indirection + deriving (Show) + +optExpr :: CompilerOpts -> Expr -> CompM ([Stmt], Expr) +optExpr opts e | not (co_on opts) = return ([],e) +optExpr _opts e = do + Graph g start <- liftIO $ reifyGraph (ExprE e) + + let db0 = Map.fromList [ (n,Inst e') | (n,e') <- g ] + + let out = stronglyConnComp + [ (n,n,case e' of + Apply f xs -> f : xs + _ -> []) + | (n,e') <- g + ] + + let ids = filter (/= start) $ flattenSCCs $ out + + jsVars :: Map.Map Uniq String <- liftM Map.fromList $ sequence + [ do v <- uniqM + return (n,"c" ++ show v) + | n <- ids + , Just (Inst (Apply {})) <- [ Map.lookup n db0 ] + ] + + let findExpr vars db n = + case Map.lookup n vars of + Just v -> Var v + Nothing -> case Map.lookup n db of + Just (Inst oper) -> fmap (ExprE . findExpr vars db) oper + Just (Copy n') -> findExpr vars db n' +-- Just op -> fmap (ExprE . findExpr db) op + Nothing -> error $ "optExpr: findExpr failed for " ++ show n + + -- replace dumb statement with better ones + let folder :: (Ord n) + => Map.Map n e + -> [n] + -> (e -> Map.Map n e -> Maybe e) + -> Map.Map n e + folder db [] _f = db + folder db (n:ns) f = case Map.lookup n db of + Nothing -> error "bad folder" + Just e' -> case f e' db of + Nothing -> folder db ns f + Just e'' -> folder (Map.insert n e'' db) ns f + + let db1 = folder db0 ids $ \ e' db -> + let --getExpr :: Uniq -> Expr + --getExpr = findExpr Map.empty db + + getVar :: Uniq -> Maybe String + getVar expr = case findExpr jsVars db expr of { Var x -> return x ; _ -> Nothing } + + getLit :: Uniq -> Maybe String + getLit expr = case findExpr Map.empty db expr of { Lit x -> return x ; _ -> Nothing } + + in case e' of + -- var c4770 = 0.0<=0.0; + (Inst (Apply g' [x,y])) | getVar g' == Just "<=" + && isJust (getLit x) + && isJust (getLit y) + && getLit x == getLit y + -> return (Inst (Lit "true")) + -- var c4770 = true; + -- var c4771 = c4770?0.0:0.0; + Inst (Apply g' [x,y,z]) + | getVar g' == Just "?:" && getLit x == return "true" + -> return (Copy y) + | getVar g' == Just "?:" && getLit x == return "false" + -> return (Copy z) + _ -> Nothing + -- Next, do a forward push of value numbering + let dbF = db1 + return ([ mkVarStmt c $ case e' of + Inst expr -> fmap (ExprE . findExpr jsVars dbF) expr + Copy n' -> -- Apply (ExprE (Var "COPY")) [ ExprE $ findExpr jsVars dbF n' ] + findExpr jsVars dbF n' + | n <- ids + , Just c <- return $ Map.lookup n jsVars + , Just e' <- return $ Map.lookup n dbF + ], findExpr jsVars dbF start) + + +----------------------------------------------------------------------------------- + +type CompM = ReaderT CompilerOpts (StateT Uniq IO) + +instance UniqM CompM where + uniqM = do + n <- get + modify (+1) + return n + +newVar :: CompM Id +newVar = uniqM >>= return . ("v" ++) . show + +--varId :: Sunroof a => a -> Id +--varId = varIdE . unbox + +var :: Sunroof a => Id -> a +var = box . Var + +varIdE :: Expr -> Id +varIdE e = case e of + (Var v) -> v + v -> error $ "varId: Expressions is not a variable: " ++ show v + +---------------------------------------------------------------------------------- + +mkVarStmt :: Id -> Expr -> Stmt +mkVarStmt v e = AssignStmt (VarRhs v) e diff --git a/Language/Sunroof/Concurrent.hs b/Language/Sunroof/Concurrent.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/Concurrent.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Provides common combinators for concurrency in Javascript. +-- +-- The emulated threading Javascript threading model provided by +-- Sunroof is based on cooperative multithreading +-- (since Javascript is not multithreaded). +module Language.Sunroof.Concurrent + ( loop + , forkJS + , threadDelay + , yield + ) where + +import Language.Sunroof.Types +import Language.Sunroof.Classes ( Sunroof(..) ) +import Language.Sunroof.JS.Ref ( newJSRef, readJSRef, writeJSRef, JSRef ) +import Language.Sunroof.JS.Number ( JSNumber ) +import Language.Sunroof.JS.Browser ( window, setTimeout ) + +-- ------------------------------------------------------------- +-- General Concurrent Combinators. +-- ------------------------------------------------------------- + +-- | @loop x f@ executes the function @f@ repeatedly. +-- After each iteration the result value of the function +-- is feed back as input of the next iteration. +-- The initial value supplied for the first iteration is @x@. +-- This loop will never terminate. +loop :: (Sunroof a) => a -> (a -> JSB a) -> JSB () +loop start m = do + v :: JSRef (JSContinuation ()) <- newJSRef (cast nullJS) + s <- newJSRef start + f <- continuation $ \ () -> do + a <- readJSRef s + a' <- m a + s # writeJSRef a' + f <- readJSRef v + _ <- liftJS $ window # setTimeout (\x -> goto f x) 0 + return () + v # writeJSRef f + _ <- goto f () -- and call the function + return () + +-- | Fork of the given computation in a different thread. +forkJS :: (SunroofThread t1) => JS t1 () -> JS t2 () +forkJS m = do + _ <- window # setTimeout (\() -> blockableJS m) 0 + return () + +-- | Delay the execution of all instructions after this one by +-- the given amount of milliseconds. +threadDelay :: JSNumber -> JSB () +threadDelay n = callcc $ \ o -> do + _ <- window # setTimeout (\x -> goto o x) n + done + +-- | Give another thread time to execute. +yield :: JSB () +yield = threadDelay 0 + + + + + + + + + + + + + diff --git a/Language/Sunroof/Internal.hs b/Language/Sunroof/Internal.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/Internal.hs @@ -0,0 +1,19 @@ + +-- | Internal helper functions. +module Language.Sunroof.Internal + ( proxyOf + , litparen + ) where + +import Data.Char ( isDigit ) +import Data.Proxy ( Proxy(Proxy) ) + +-- | Helps to get the proxy of a value. +proxyOf :: a -> Proxy a +proxyOf _ = Proxy + +-- | Determines wether a Javascript literal, given as a string, +-- requires parenthesis and adds them if so. +litparen :: String -> String +litparen nm | all (\ c -> isDigit c || c == '.') nm = nm + | otherwise = "(" ++ nm ++ ")" diff --git a/Language/Sunroof/JS/Array.hs b/Language/Sunroof/JS/Array.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/JS/Array.hs @@ -0,0 +1,116 @@ + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Provides a more specific type for arrays in Javascript +-- (together with basic operations on them). +module Language.Sunroof.JS.Array + ( JSArray + , array, newArray + , length' + , lookup' + , insert' + , push, pop + , shift, unshift + , forEach + , empty + ) where + +import Prelude hiding ( lookup, length ) + +import Data.List ( intercalate ) +import Data.Boolean ( BooleanOf, IfB(..) ) + +import Language.Sunroof.JavaScript ( Expr, showExpr, literal ) +import Language.Sunroof.Types +import Language.Sunroof.Classes ( Sunroof(..), SunroofValue(..), SunroofArgument(..) ) +import Language.Sunroof.Selector ( JSSelector, index, (!) ) +import Language.Sunroof.JS.Bool ( JSBool, jsIfB ) +import Language.Sunroof.JS.Number ( JSNumber ) + +-- ------------------------------------------------------------- +-- JSArray Type +-- ------------------------------------------------------------- + +-- | Type if arrays in Javascript. The type parameter +-- given the entry type. +data JSArray a = JSArray Expr + +-- | Show the Javascript. +instance Show (JSArray a) where + show (JSArray v) = showExpr False v + +-- | Arrays are first-class Javascript values. +instance (Sunroof a) => Sunroof (JSArray a) where + box = JSArray + unbox (JSArray o) = o + +-- | The boolean of arrays are 'JSBool'. +type instance BooleanOf (JSArray a) = JSBool + +-- | You can write branches that return arrays. +instance (Sunroof a) => IfB (JSArray a) where + ifB = jsIfB + +-- ------------------------------------------------------------- +-- JSArray Combinators +-- ------------------------------------------------------------- + +-- | Create a literal array from a Haskell list. +array :: (SunroofValue a, Sunroof (ValueOf a)) => [a] -> JS t (JSArray (ValueOf a)) +array l = evaluate $ box $ literal $ "[" ++ intercalate "," (fmap (showExpr False . unbox . js) l) ++ "]" + +-- | Create a new array object containing the given values. +newArray :: (SunroofArgument args, Sunroof a) => args -> JS t (JSArray a) +newArray args = cast `fmap` new "Array" args + +-- | The empty array. +empty :: (Sunroof a) => JS t (JSArray a) +empty = evaluate $ box $ literal "[]" + +-- | The @length@ property of arrays. +length' :: JSSelector JSNumber +length' = attr "length" + +-- | A type-safe version of array lookup. +lookup' :: (Sunroof a) => JSNumber -> JSArray a -> a +lookup' n e = e ! index n + +-- | A type-safe version of array insert. +insert' :: (Sunroof a) => JSNumber -> a -> JSArray a -> JS t () +insert' n a e = e # index n := a + +-- | Push a element into the array as if it was a stack. +-- Returns nothing instead of the new length. +-- See . +push :: (SunroofArgument a, Sunroof a) => a -> JSArray a -> JS t () +push a = invoke "push" a + +-- | Adds a new element to the beginning of the array (queue). +-- Returns nothing instead of the new length. +-- See . +unshift :: (SunroofArgument a, Sunroof a) => a -> JSArray a -> JS t () +unshift a = invoke "unshift" a + +-- | Pop a element from the array as if it was a stack. +-- See . +pop :: (Sunroof a) => JSArray a -> JS t a +pop = invoke "pop" () + +-- | Removes and return the first element of an array (dequeue). +-- See . +shift :: (Sunroof a) => JSArray a -> JS t a +shift = invoke "shift" () + +-- | Foreach iteration method provided by most browsers. +-- Execute the given action on each element of the array. +-- See +-- , +-- . +forEach :: (Sunroof a, SunroofArgument a) => (a -> JS A ()) -> JSArray a -> JS t () +forEach body arr = do + f <- function body + arr # invoke "forEach" f :: JS t () + return () diff --git a/Language/Sunroof/JS/Bool.hs b/Language/Sunroof/JS/Bool.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/JS/Bool.hs @@ -0,0 +1,63 @@ + +{-# LANGUAGE TypeFamilies #-} + +-- | Booleans in Javascript. +module Language.Sunroof.JS.Bool + ( JSBool + , jsIfB + ) where + +import Data.Boolean ( Boolean(..), BooleanOf, IfB(..), EqB(..) ) + +import Language.Sunroof.JavaScript + ( Expr + , operator, binOp, uniOp + , literal, showExpr ) +import Language.Sunroof.Classes ( Sunroof(..), SunroofValue(..) ) + +-- ------------------------------------------------------------- +-- JSBool Type +-- ------------------------------------------------------------- + +-- | Booleans in Javascript. +data JSBool = JSBool Expr + +instance Show JSBool where + show (JSBool e) = showExpr False e + +instance Sunroof JSBool where + box = JSBool + unbox (JSBool v) = v + +instance Boolean JSBool where + true = box $ literal "true" + false = box $ literal "false" + notB (JSBool e1) = box $ uniOp "!" e1 + (&&*) (JSBool e1) + (JSBool e2) = box $ binOp "&&" e1 e2 + (||*) (JSBool e1) + (JSBool e2) = box $ binOp "||" e1 e2 + +type instance BooleanOf JSBool = JSBool + +instance IfB JSBool where + ifB = jsIfB + +instance EqB JSBool where + (==*) e1 e2 = box $ binOp "==" (unbox e1) (unbox e2) + (/=*) e1 e2 = box $ binOp "!=" (unbox e1) (unbox e2) + +instance SunroofValue Bool where + type ValueOf Bool = JSBool + js True = true + js False = false + +-- ------------------------------------------------------------- +-- JSBool Combinators +-- ------------------------------------------------------------- + +-- | Combinator for @if-then-else@ expressions. Not intended +-- for usage. Provided as a convenience for 'Data.Boolean.IfB' +-- instances. Use 'Data.Boolean.ifB' instead. +jsIfB :: (Sunroof a) => JSBool -> a -> a -> a +jsIfB (JSBool c) t e = box $ operator "?:" [c, unbox t, unbox e] diff --git a/Language/Sunroof/JS/Browser.hs b/Language/Sunroof/JS/Browser.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/JS/Browser.hs @@ -0,0 +1,349 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Language.Sunroof.JS.Browser +-- Copyright : (c) 2011 The University of Kansas +-- License : BSD-style (see LICENSE) +-- Maintainer : ??? +-- +-- A reflection of the standard browser Javascript API. +-- +module Language.Sunroof.JS.Browser + ( -- * Top level functions + alert + , confirm + , prompt + , decodeURI + , encodeURI + , decodeURIComponent + , encodeURIComponent + , eval + , isFinite + , isNaN + , parseFloat + , parseInt + -- * Window API + , window + , setInterval + , clearInterval + , setTimeout + , clearTimeout + -- * Screen API + , screen + -- * Document API + , document + , getElementById + , getElementsByName + , getElementsByTagName + , createAttribute + , createElement + , createTextNode + , open + , close + , write + , writeln + , setCookie + , cookie + , referrer + , setTitle + , title + , url + -- * Image DOM + , src + -- * The JavaScript Console + , JSConsole + , console + , Language.Sunroof.JS.Browser.log + , debug + , info + , warn + , Language.Sunroof.JS.Browser.error + ) where + +import Prelude hiding (isNaN) + +import Data.Boolean ( BooleanOf, IfB(..), EqB(..) ) + +import Language.Sunroof.Types + ( JS, JSB + , JS ( (:=) ) + , fun + , invoke + , attr + , apply + , (#) + , continuation + ) +import Language.Sunroof.Classes ( Sunroof(..), SunroofArgument ) +import Language.Sunroof.Selector ( JSSelector ) +import Language.Sunroof.JS.Bool ( JSBool, jsIfB ) +import Language.Sunroof.JS.Object ( JSObject, object ) +import Language.Sunroof.JS.String ( JSString ) +import Language.Sunroof.JS.Number ( JSNumber ) + +-- ----------------------------------------------------------------------- +-- Object Independent Functions +-- ----------------------------------------------------------------------- + +-- | Display the given text in a message box. +-- +-- See . +alert :: JSString -> JS t () +alert msg = fun "alert" `apply` (msg) + +-- | Ask the user to confirm the given massege. +-- +-- See . +confirm :: JSString -> JS t JSBool +confirm msg = fun "confirm" `apply` (msg) + +-- | Ask the user to give some input. May return @null@ +-- or a string. Don't forget to check against 'nullJS' +-- before casting to string. +-- +-- See . +prompt :: JSString -> JSString -> JS t JSObject +prompt msg val = fun "prompt" `apply` (msg, val) + +-- | Decode the URI encoded in the given string. +decodeURI :: JSString -> JS t JSString +decodeURI str = fun "decodeURI" `apply` (str) + +-- | Encode the given string in URI encoding. +encodeURI :: JSString -> JS t JSString +encodeURI str = fun "encodeURI" `apply` (str) + +-- | Decode the URI encoded string. For use with 'encodeURIComponent'. +decodeURIComponent :: JSString -> JS t JSString +decodeURIComponent str = fun "decodeURIComponent" `apply` (str) + +-- | Encode the string with URI encoding. This encodes a few more +-- characters to make the string safe for direct server communication (AJAX). +encodeURIComponent :: JSString -> JS t JSString +encodeURIComponent str = fun "encodeURIComponent" `apply` (str) + +-- | Evaluate the given JavaScript string if possible. Returns +-- the result of evaluation. +-- TODO: think about this a bit. +eval :: (Sunroof a) => JSString -> JS t a +eval str = fun "eval" `apply` (str) + +-- | Check if a given number is within the valid JavaScript number range. +isFinite :: JSNumber -> JS t JSBool +isFinite n = fun "isFinite" `apply` (n) + +-- | Check if a given number is NaN or not. +isNaN :: JSNumber -> JS t JSBool +isNaN n = fun "isNaN" `apply` (n) + +-- | Parse the given string to a number. +parseFloat :: JSString -> JS t JSNumber +parseFloat str = fun "parseFloat" `apply` (str) + +-- | Parse the given string to a number. +parseInt :: JSString -> JS t JSNumber +parseInt str = fun "parseInt" `apply` (str) + +-- ----------------------------------------------------------------------- +-- Window API +-- ----------------------------------------------------------------------- + +-- | The window object. +window :: JSObject +window = object "window" + +-- | Calls a function at specified intervals in milliseconds. +-- It will continue calling the function until 'clearInterval' is called, +-- or the window is closed. The returned number is needed for 'clearInterval'. +-- This is supposed to be called on the 'window' object. +-- See: +setInterval :: (() -> JSB ()) -> JSNumber -> JSObject -> JS t JSNumber +setInterval f interval o = do + callback <- continuation f + o # invoke "setInterval" (callback, interval) + +-- | Clears a timer set with the 'setInterval' method. +-- This is supposed to be called on the 'window' object. +-- See: +clearInterval :: JSNumber -> JSObject -> JS t () +clearInterval ident = invoke "clearInterval" (ident) + +-- | Execute the given continutation after the given amount of +-- milliseconds. Returns a handler for the set timer. +-- This is supposed to be called on the 'window' object. +-- See: +setTimeout :: (() -> JSB ()) -> JSNumber -> JSObject -> JS t JSNumber +setTimeout f interval o = do + callback <- continuation f + o # invoke "setTimeout" (callback, interval) + +-- | Removes the timer associated with the given handler. +-- This is supposed to be called on the 'window' object. +-- See: +clearTimeout :: JSNumber -> JSObject -> JS t () +clearTimeout ident = invoke "clearTimeout" (ident) + +-- ----------------------------------------------------------------------- +-- Screen API +-- ----------------------------------------------------------------------- + +-- | The screen object. +screen :: JSObject +screen = object "screen" + +-- ----------------------------------------------------------------------- +-- Document API +-- ----------------------------------------------------------------------- + +-- | The document object. +document :: JSObject +document = object "document" + +-- | Get the DOM object of the element with the given id. +-- For use with 'document'. +getElementById :: JSString -- ^ The id. + -> JSObject -> JS t JSObject +getElementById ident = invoke "getElementById" (ident) + +-- | Get the DOM objects of the elements with the given name. +-- For use with 'document'. +getElementsByName :: JSString -- ^ The name. + -> JSObject -> JS t JSObject +getElementsByName name = invoke "getElementsByName" (name) + +-- | Get the DOM objects of the elements with the given tag. +-- For use with 'document'. +getElementsByTagName :: JSString -- ^ The tag name. + -> JSObject -> JS t JSObject +getElementsByTagName tag = invoke "getElementsByTagName" (tag) + +-- | Create a attribute DOM node with the given name. +-- For use with 'document'. +createAttribute :: JSString -- ^ The name of the new attribute. + -> JSObject -> JS t JSObject +createAttribute a = invoke "createAttribute" (a) + +-- | Create a element DOM node with the given tag name. +-- For use with 'document'. +createElement :: JSString -- ^ The tag name of the new element. + -> JSObject -> JS t JSObject +createElement e = invoke "createElement" (e) + +-- | Create a text DOM node with the given string as text. +-- For use with 'document'. +createTextNode :: JSString -- ^ The text of the new text node. + -> JSObject -> JS t JSObject +createTextNode text = invoke "createTextNode" (text) + +-- | Opens the document for writing. +-- For use with 'document'. +open :: JSObject -> JS t () +open = invoke "open" () + +-- | Closes the document after writing. +-- For use with 'document'. +close :: JSObject -> JS t () +close = invoke "close" () + +-- | Writes something into the document. +-- For use with 'document'. +write :: JSString -> JSObject -> JS t () +write str = invoke "write" (str) + +-- | Write something into the document and appends a new line. +-- For use with 'document'. +writeln :: JSString -> JSObject -> JS t () +writeln str = invoke "writeln" (str) + +-- | Sets the value of the cookie. +-- For use with 'document'. +setCookie :: JSString -> JSObject -> JS t () +setCookie c = "cookie" := c + +-- | Returns the value of the cookie. +-- For use with 'document'. +cookie :: JSSelector JSString +cookie = attr "cookie" + +-- | Returns the referrer of the document. +-- For use with 'document'. +referrer :: JSSelector JSString +referrer = attr "referrer" + +-- | Sets the title of the document. +-- For use with 'document'. +setTitle :: JSString -> JSObject -> JS t () +setTitle t = "title" := t + +-- | Returns the title of the document. +-- For use with 'document'. +title :: JSSelector JSString +title = attr "title" + +-- | Returns the complete URL of the document. +-- For use with 'document'. +url :: JSSelector JSString +url = attr "URL" + +-- | Returns the src of a DOM image object. +src :: JSSelector JSString +src = attr "src" + +-- ----------------------------------------------------------------------- +-- Console API +-- ----------------------------------------------------------------------- + +-- | The type of the debugging console object. +-- See: +-- , +-- , +-- ; +data JSConsole = JSConsole JSObject + +-- | Show the Javascript. +instance Show JSConsole where + show (JSConsole o) = show o + +-- | First-class values in Javascript. +instance Sunroof JSConsole where + box = JSConsole . box + unbox (JSConsole e) = unbox e + +-- | Associated boolean is 'JSBool'. +type instance BooleanOf JSConsole = JSBool + +-- | Can be returned in branches. +instance IfB JSConsole where + ifB = jsIfB + +-- | Reference equality, not value equality. +instance EqB JSConsole where + (JSConsole a) ==* (JSConsole b) = a ==* b + +-- | The console object. +console :: JSConsole +console = JSConsole (object "console") + +-- | Log the given message. +log :: (SunroofArgument a) => a -> JSConsole -> JS t () +log a (JSConsole o) = o # invoke "log" a + +-- | Send a debug level message to the console. +debug :: (SunroofArgument a) => a -> JSConsole -> JS t () +debug a (JSConsole o) = o # invoke "debug" a + +-- | Send a info message to the console. +info :: (SunroofArgument a) => a -> JSConsole -> JS t () +info a (JSConsole o) = o # invoke "info" a + +-- | Send a warning message to the console. +warn :: (SunroofArgument a) => a -> JSConsole -> JS t () +warn a (JSConsole o) = o # invoke "warn" a + +-- | Send an error message to the console. +error :: (SunroofArgument a) => a -> JSConsole -> JS t () +error a (JSConsole o) = o # invoke "error" a + + diff --git a/Language/Sunroof/JS/Canvas.hs b/Language/Sunroof/JS/Canvas.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/JS/Canvas.hs @@ -0,0 +1,480 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Provides bindings to the Javascript API of the +-- HTML5 canvas element. +-- +-- See . +module Language.Sunroof.JS.Canvas + ( JSCanvas + , getContext + , arc, arc', arcTo + , beginPath + , bezierCurveTo + , clearRect, clip + , closePath + , createImageData, createImageData' + , drawImage, drawImage', drawImageClip + , fill, fillRect + , setFillStyle + , fillText, fillText' + , setFont + , getImageData + , setGlobalAlpha + , isPointInPath + , setLineCap, setLineJoin + , lineTo + , setLineWidth + , miterLimit + , setMiterLimit + , measureText + , moveTo + , putImageData + , rect + , restore + , rotate, scale + , save + , setTransform + , setShadowColor, setShadowBlur + , setShadowOffsetX, setShadowOffsetY + , stroke, strokeRect, strokeText + , setStrokeStyle + , setTextAlign, setTextBaseline + , transform, translate + , quadraticCurveTo + , width, height + , data' + , globalAlpha + , shadowColor, shadowBlur + , shadowOffsetX, shadowOffsetY + , strokeStyle + , textAlign, textBaseline + , lineCap, lineJoin, lineWidth + , font + ) where + +import Data.Boolean ( BooleanOf, IfB(..), EqB(..) ) + +import Language.Sunroof.Classes ( Sunroof(..) ) +import Language.Sunroof.Types +import Language.Sunroof.Selector ( JSSelector, label ) +import Language.Sunroof.JS.Bool ( JSBool, jsIfB ) +import Language.Sunroof.JS.Object ( JSObject ) +import Language.Sunroof.JS.String ( JSString, string ) +import Language.Sunroof.JS.Number ( JSNumber ) + +-- ------------------------------------------------------------- +-- JSCanvas Type +-- ------------------------------------------------------------- + +-- | The type of the canvas drawing context. +newtype JSCanvas = JSCanvas JSObject + +-- | Show the Javascript. +instance Show JSCanvas where + show (JSCanvas o) = show o + +-- | First-class values in Javascript. +instance Sunroof JSCanvas where + box = JSCanvas . box + unbox (JSCanvas o) = unbox o + +-- | Associated boolean is 'JSBool'. +type instance BooleanOf JSCanvas = JSBool + +-- | Can be returned in branches. +instance IfB JSCanvas where + ifB = jsIfB + +-- | Reference equality, not value equality. +instance EqB JSCanvas where + (JSCanvas a) ==* (JSCanvas b) = a ==* b + +-- ------------------------------------------------------------- +-- JSCanvas Combinators +-- ------------------------------------------------------------- + +-- | Returns the canvas drawing context for the canvas element it +-- is called on. +getContext :: JSString -> JSObject -> JS t JSCanvas +getContext nm = invoke "getContext" nm + +-- | Draws a circular arc. +arc :: (JSNumber,JSNumber) -- ^ The x and y component of the center point. + -> JSNumber -- ^ The radius. + -> (JSNumber,JSNumber) -- ^ The angle to start and the angle to stop drawing. + -> JSCanvas -> JS t () +arc (cx,cy) r (sa,ea) = + invoke "arc" (cx, cy, r, sa, ea) + +-- | Draws a circular arc. +arc' :: (JSNumber,JSNumber) -- ^ The x and y component of the center point. + -> JSNumber -- ^ The radius. + -> (JSNumber,JSNumber) -- ^ The angle to start and the angle to stop drawing. + -> JSBool -- ^ If the arc shall be drawn counterclockwise. + -> JSCanvas -> JS t () +arc' (cx,cy) r (sa,ea) cc = + invoke "arc" (cx, cy, r, sa, ea, cc) + +-- | Creates an arc between two tangents on the canvas. +arcTo :: (JSNumber, JSNumber) -- ^ The x and y coordinate of the beginning of the arc. + -> (JSNumber, JSNumber) -- ^ The x and y coordinate of the end of the arc. + -> JSNumber -- ^ The radius of the arc. + -> JSCanvas -> JS t () +arcTo (x1, y1) (x2, y2) r = + invoke "arcTo" (x1, y1, x2, y2, r) + +-- | Begins drawing a path or resets the current path +beginPath :: JSCanvas -> JS t () +beginPath = invoke "beginPath" () + +-- | Draws a bezier curve beginning at the current position of the context. +bezierCurveTo :: (JSNumber,JSNumber) -- ^ The first control point. + -> (JSNumber,JSNumber) -- ^ The second control point. + -> (JSNumber,JSNumber) -- ^ The endpoint of the curve. + -> JSCanvas -> JS t () +bezierCurveTo (a,b) (c,d) (e,f) = + invoke "bezierCurveTo" (a, b, c, d, e, f) + +-- | Clears the rectangle given by its location and size. +clearRect :: (JSNumber,JSNumber) -- ^ The top left corner of the rectanlge to clear. + -> (JSNumber,JSNumber) -- ^ The width and height of the rectangle to clear. + -> JSCanvas -> JS t () +clearRect (x,y) (w,h) = invoke "clearRect" (x, y, w, h) + +-- | Clips a region of any shape and size from the context. +clip :: JSCanvas -> JS t () +clip = invoke "clip" () + +-- | Closes the current path by drawing a straight line back to its beginning. +closePath :: JSCanvas -> JS t () +closePath = invoke "closePath" () + +-- | Create a new image data object with the given size. +createImageData :: (JSNumber, JSNumber) -- ^ The width and hight of the new object. + -> JSCanvas -> JS t JSObject -- ^ Returns the new image data object. +createImageData (w,h) = invoke "createImageData" (w, h) + +-- | Creates a new image data object with the same dimension as the given +-- image data object. This does not copy the contents of the other object. +createImageData' :: JSObject -- ^ The other image data object. + -> JSCanvas -> JS t JSObject -- ^ Returns the new image data object. +createImageData' imgData = invoke "createImageData" (imgData) + +-- | Draws an image, video or canvas to the canvas. +drawImage :: JSObject -- ^ The graphical object to draw. + -> (JSNumber, JSNumber) -- ^ The x and y coordinate of the top left corner. + -> JSCanvas -> JS t () +drawImage img (x,y) = invoke "drawImage" (img, x, y) + +-- | Draws an image, video or canvas to the canvas. +drawImage' :: JSObject -- ^ The graphical object to draw. + -> (JSNumber, JSNumber) -- ^ The x and y coordinate of the top left corner. + -> (JSNumber, JSNumber) -- ^ The width and height to scale the image to. + -> JSCanvas -> JS t () +drawImage' img (x,y) (w,h) = + invoke "drawImage" (img, x, y, w, h) + +-- | Draws an image, video or canvas to the canvas. Clips the drawn object. +drawImageClip :: JSObject -- ^ The graphical object to draw. + -> (JSNumber, JSNumber) -- ^ The x and y coordinate of the top + -- left corner of the clippng area. + -> (JSNumber, JSNumber) -- ^ The width and height of the clipping area + -> (JSNumber, JSNumber) -- ^ The x and y coordinate of the top left corner. + -> (JSNumber, JSNumber) -- ^ The width and height to scale the image to. + -> JSCanvas -> JS t () +drawImageClip img (cx, cy) (cw, ch) (x,y) (w,h) = + invoke "drawImage" ( img + , cx, cy + , cw, ch + , x, y + , w, h) + +-- | Fills the current path with the current fill style. +fill :: JSCanvas -> JS t () +fill = invoke "fill" () + +-- | Draws a filled rectangle given by its top left corner and size with the +-- current fill style. +fillRect :: (JSNumber,JSNumber) -- ^ The top left corner of the rectangle. + -> (JSNumber,JSNumber) -- ^ The width and height of the rectangle. + -> JSCanvas -> JS t () +fillRect (x,y) (w,h) = invoke "fillRect" (x, y, w, h) + +-- | Sets the fill style of the context. A color value of the form "#XXXXXX" +-- is expected. +setFillStyle :: JSString -> JSCanvas -> JS t () +-- TODO: Add support for gradients and patterns. +setFillStyle fs = "fillStyle" := fs + +-- | Fills a text with the current fill style. +fillText :: JSString -- ^ The text to fill. + -> (JSNumber,JSNumber) -- ^ The x and y position of the + -- bottom left corner of the text. + -> JSCanvas -> JS t () +fillText s (x,y) = invoke "fillText" (s, x, y) + +-- | Fills a text with the current fill style. +fillText' :: JSString -- ^ The text to fill. + -> (JSNumber, JSNumber) -- ^ The x and y position of the + -- bottom left corner of the text. + -> JSNumber -- ^ The maximum allowed width of the text. + -> JSCanvas -> JS t () +fillText' s (x,y) maxW = invoke "fillText" (s, x, y, maxW) + +-- | Sets the font used by the context. +setFont :: JSString -> JSCanvas -> JS t () +setFont f = "font" := f + +-- | Get the image data of the specified rectanlge of the canvas. +getImageData :: (JSNumber, JSNumber) -- ^ The x and y coordinate of the top left + -- corner of the rectangle to extract. + -> (JSNumber, JSNumber) -- ^ The width and height of the rectangle. + -> JSCanvas -> JS t JSObject -- ^ Returns the image data object + -- with the extracted information. +getImageData (x,y) (w,h) = + invoke "getImageData" (x, y, w , h) + +-- | Sets the global alpha value. +setGlobalAlpha :: JSNumber -> JSCanvas -> JS t () +setGlobalAlpha a = "globalAlpha" := a + +-- | Returns true if the given point is in the path and false otherwise. +isPointInPath :: (JSNumber, JSNumber) -- ^ The x and y coordinate of the point to check + -> JSCanvas -> JS t JSBool +isPointInPath (x,y) = invoke "isPointInPath" (x, y) + +-- | Sets the line cap style to use. +-- Possible values are: "butt", "round", "square"; +setLineCap :: JSString -> JSCanvas -> JS t () +setLineCap lc = "lineCap" := lc + +-- | Sets the line join style to use. +-- Possible values are: "bevel", "round", "meter"; +setLineJoin :: JSString -> JSCanvas -> JS t () +setLineJoin lj = "lineJoin" := lj + +-- | Create a straight line path from the current point to the given point. +lineTo :: (JSNumber,JSNumber) -- ^ The x and y location the line is drawn to. + -> JSCanvas -> JS t () +lineTo (x,y) = invoke "lineTo" (x, y) + +-- | Sets the line width used when stroking. +setLineWidth :: JSNumber -- ^ The line new line width in pixels. + -> JSCanvas -> JS t () +setLineWidth lw = "lineWidth" := lw + +-- | Returns the miter limit used when drawing a miter line join. +miterLimit :: JSSelector JSNumber +miterLimit = label $ string "miterLimit" + +-- | Sets the miter limit used when drawing a miter line join. +setMiterLimit :: JSNumber -- ^ The new miter limit. + -> JSCanvas -> JS t () +setMiterLimit ml = "miterLimit" := ml + +-- | Returns an object that contains the width of the specified text is pixels. +-- See 'width' selector. +measureText :: JSString -- ^ The text to be measured. + -> JSCanvas -> JS t JSObject +measureText s = invoke "measureText" (s) + +-- | Move the path to the given location. +moveTo :: (JSNumber,JSNumber) -- ^ The new x and y location of the path. + -> JSCanvas -> JS t () +moveTo (x,y) = invoke "moveTo" (x, y) + +-- | Uses the given image data to replace the rectangle of the +-- canvas at the given position. +putImageData :: JSObject -- ^ The new image data. + -> (JSNumber, JSNumber) -- ^ The x and y coordinate of the top left corner. + -> JSCanvas -> JS t () +putImageData imgData (x,y) = invoke "putImageData" (imgData, x, y) + +-- | Creates a rectangle in the current context. +rect :: (JSNumber,JSNumber) -- ^ The top left corner of the rectangle. + -> (JSNumber,JSNumber) -- ^ The width and height of the rectangle. + -> JSCanvas -> JS t () +rect (x,y) (w,h) = invoke "rect" (x, y, w, h) + +-- | Restores the last saved paths and state of the context. +restore :: JSCanvas -> JS t () +restore = invoke "restore" () + +-- | Rotates the current drawing. The rotation will only affect drawings +-- made after the rotation. +rotate :: JSNumber -- ^ The rotation angle in radians. + -> JSCanvas -> JS t () +rotate a = invoke "rotate" (a) + +-- | Scales the current drawing. +scale :: (JSNumber,JSNumber) -- ^ The factors to scale the + -- width and the height with. + -> JSCanvas -> JS t () +scale (sw,sh) = invoke "scale" (sw, sh) + +-- | Saves the state of the current context. +save :: JSCanvas -> JS t () +save = invoke "save" () + +-- | Resets the transformation matrix to identity and then applies +-- 'transform' with the given paramters to it. +setTransform :: JSNumber -- ^ Scales the drawings horizontally. + -> JSNumber -- ^ Skew the drawings horizontally. + -> JSNumber -- ^ Skew the drawings vertically. + -> JSNumber -- ^ Scales the drawings vertically. + -> JSNumber -- ^ Moves the drawings horizontally. + -> JSNumber -- ^ Moves the drawings vertically. + -> JSCanvas -> JS t () +setTransform a b c d e f = + invoke "setTransform" (a, b, c, d, e, f) + +-- | Sets the shadow color property. +-- The given string has to be a valid CSS color value or a +-- color of the form '#XXXXXX' +setShadowColor :: JSString -- ^ The color to use as shadow color. + -> JSCanvas -> JS t () +setShadowColor c = "shadowColor" := c + +-- | Sets the blur level for shadows. +setShadowBlur :: JSNumber -- ^ The blur level for the shadow in pixels. + -> JSCanvas -> JS t () +setShadowBlur b = "shadowBlur" := b + +-- | Sets the x offset of a shadow from a shape. +setShadowOffsetX :: JSNumber -- ^ The x offset of the shadow in pixels. + -> JSCanvas -> JS t () +setShadowOffsetX x = "shadowOffsetX" := x + +-- | Sets the y offset of a shadow from a shape. +setShadowOffsetY :: JSNumber -- ^ The y offset of the shadow in pixels. + -> JSCanvas -> JS t () +setShadowOffsetY y = "shadowOffsetY" := y + +-- | Draws the current path using the current stroke style. +stroke :: JSCanvas -> JS t () +stroke = invoke "stroke" () + +-- | Strokes a rectanlge using the current stroke style. +strokeRect :: (JSNumber,JSNumber) -- ^ The x and y coordinate of the top left corner. + -> (JSNumber,JSNumber) -- ^ The width and height of the rectangle. + -> JSCanvas -> JS t () +strokeRect (x,y) (w,h) = invoke "strokeRect" (x, y, w, h) + +-- | Strokes a text using the current stroke style. +strokeText :: JSString -- ^ The text to stroke. + -> (JSNumber,JSNumber) -- ^ The x and y coordinate to stroke the text at. + -> JSCanvas -> JS t () +strokeText s (x,y) = invoke "strokeText" (s, x, y) + +-- | Sets the stroke style of the context. A color value of the form "#XXXXXX" +-- is expected. +setStrokeStyle :: JSString -> JSCanvas -> JS t () +-- TODO: Add support for patterns and gradients. +setStrokeStyle c = "strokeStyle" := c + +-- | Sets the text alignment to be used when drawing text. +-- Possible values are: "center", "end", "left", "right", "start" +setTextAlign :: JSString -> JSCanvas -> JS t () +setTextAlign ta = "textAlign" := ta + +-- | Sets the baseline to use when drawing text. +-- Possible values are: "alphabetic", "top", "hanging", "middle", "ideographic", "bottom" +setTextBaseline :: JSString -> JSCanvas -> JS t () +setTextBaseline tb = "textBaseline" := tb + +-- | Alters the current transformation matrix. The current one is +-- multiplied with one of the form: +-- @ +-- a b c +-- d e f +-- 0 0 1 +-- @ +transform :: JSNumber -- ^ The 'a' value. + -> JSNumber -- ^ The 'b' value. + -> JSNumber -- ^ The 'c' value. + -> JSNumber -- ^ The 'd' value. + -> JSNumber -- ^ The 'e' value. + -> JSNumber -- ^ The 'f' value. + -> JSCanvas -> JS t () +transform a b c d e f = + invoke "transform" (a, b, c, d, e, f) + +-- | Translate the current drawing. +translate :: (JSNumber,JSNumber) -- ^ The x and y values to translate by. + -> JSCanvas -> JS t () +translate (x,y) = invoke "translate" (x, y) + +-- | Create a quadratic curve to extend the current path. +quadraticCurveTo :: (JSNumber, JSNumber) -- ^ The control point of the curve. + -> (JSNumber, JSNumber) -- ^ The endpoint of the curve. + -> JSCanvas -> JS t () +quadraticCurveTo (cx, cy) (ex, ey) = + invoke "quadraticCurveTo" (cx, cy, ex, ey) + +-- | Selects the width attribute. +width :: JSSelector JSNumber +width = attr "width" + +-- | Selects the height attribute. +height :: JSSelector JSNumber +height = attr "height" + +-- | Selects the data attribute. +data' :: JSSelector JSObject +data' = attr "data" + +-- | Selects the global alpha attribute. +globalAlpha :: JSSelector JSNumber +globalAlpha = attr "globalAlpha" + +-- | Selects the shadow color attribute. +shadowColor :: JSSelector JSString +shadowColor = attr "shadowColor" + +-- | Selects the blur level for shadows. +shadowBlur :: JSSelector JSNumber +shadowBlur = attr "shadowBlur" + +-- | Selects the x offset of a shadow from a shape. +shadowOffsetX :: JSSelector JSNumber +shadowOffsetX = attr "shadowOffsetX" + +-- | Selects the y offset of a shadow from a shape. +shadowOffsetY :: JSSelector JSNumber +shadowOffsetY = attr "shadowOffsetY" + +-- | Selects the stroke style of the context. +strokeStyle :: JSSelector JSString +-- TODO: Add support for patterns and gradients. +strokeStyle = attr "strokeStyle" + +-- | Selects the text alignment to be used when drawing text. +-- Possible values are: "center", "end", "left", "right", "start" +textAlign :: JSSelector JSString +textAlign = attr "textAlign" + +-- | Selects the baseline to use when drawing text. +-- Possible values are: "alphabetic", "top", "hanging", "middle", "ideographic", "bottom" +textBaseline :: JSSelector JSString +textBaseline = attr "textBaseline" + +-- | Sets the line cap style to use. +-- Possible values are: "butt", "round", "square"; +lineCap :: JSSelector JSString +lineCap = attr "lineCap" + +-- | Selects the line join style to use. +-- Possible values are: "bevel", "round", "meter"; +lineJoin :: JSSelector JSString +lineJoin = attr "lineJoin" + +-- | Selects the line width used when stroking. +lineWidth :: JSSelector JSNumber +lineWidth = attr "lineWidth" + +-- | Selects the font used by the context. +font :: JSSelector JSString +font = attr "font" + diff --git a/Language/Sunroof/JS/Chan.hs b/Language/Sunroof/JS/Chan.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/JS/Chan.hs @@ -0,0 +1,90 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +-- | 'JSChan' provides the same functionality and +-- concurrency abstraction in Javascript computations +-- as 'Control.Concurrent.Chan' in Haskell. +module Language.Sunroof.JS.Chan + ( JSChan + , newChan + , writeChan, readChan + ) where + +import Data.Boolean ( IfB(..), EqB(..) ) + +import Language.Sunroof.Classes + ( Sunroof(..), SunroofArgument(..) ) +import Language.Sunroof.Types +import Language.Sunroof.Concurrent ( forkJS ) +import Language.Sunroof.Selector ( (!) ) +import Language.Sunroof.TH +import Language.Sunroof.JS.Object ( JSObject ) +import Language.Sunroof.JS.Array + ( JSArray + , newArray, length' + , push, shift ) + +-- ------------------------------------------------------------- +-- JSChan Type +-- ------------------------------------------------------------- + +-- | 'JSChan' abstraction. The type parameter gives +-- the type of values held in the channel. +newtype JSChan a = JSChan JSObject + +deriveJSTuple + [d| instance (SunroofArgument o) => JSTuple (JSChan o) where + type Internals (JSChan o) = + ( (JSArray (JSContinuation (JSContinuation o))) -- callbacks of written data + , (JSArray (JSContinuation o)) -- callbacks of waiting readers + ) + |] + +-- | Reference equality, not value equality. +instance (SunroofArgument o) => EqB (JSChan o) where + (JSChan a) ==* (JSChan b) = a ==* b + +-- ------------------------------------------------------------- +-- JSChan Combinators +-- ------------------------------------------------------------- + +-- | Create a new empty 'JSChan'. +newChan :: (SunroofArgument a) => JS t (JSChan a) +newChan = do + written <- newArray () + waiting <- newArray () + tuple (written, waiting) + +-- | Put a value into the channel. This will never block. +writeChan :: forall t a . (SunroofThread t, SunroofArgument a) => a -> JSChan a -> JS t () +writeChan a (match -> (written,waiting)) = do + ifB ((waiting ! length') ==* 0) + (do f <- continuation $ \ (k :: JSContinuation a) -> goto k a :: JSB () + written # push (f :: JSContinuation (JSContinuation a)) + ) + (do f <- shift waiting + forkJS (goto f a :: JSB ()) + ) + +-- | Take a value out of the channel. If there is no value +-- inside, this will block until one is available. +readChan :: forall a . (Sunroof a, SunroofArgument a) => JSChan a -> JS B a +readChan (match -> (written,waiting)) = do + ifB ((written ! length') ==* 0) + (do -- Add yourself to the 'waiting for writer' Q. + callcc $ \ k -> do waiting # push (k :: JSContinuation a) + done + ) + (do f <- shift written + -- Here, we add our continuation into the written Q. + callcc $ \ k -> goto f k + ) + + + diff --git a/Language/Sunroof/JS/Date.hs b/Language/Sunroof/JS/Date.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/JS/Date.hs @@ -0,0 +1,294 @@ + +{-# LANGUAGE TypeFamilies #-} + +-- | The 'Date' module provides the API for the Javascript @Date@ +-- object. The API documentation is mainly taken from +-- w3schools (). +-- Deprecated methods are not supported. +module Language.Sunroof.JS.Date + ( JSDate + , newDate + , getHours, getMinutes, getSeconds + , getDate, getDay, getFullYear + , getMilliseconds, getMonth + , getTime, getTimezoneOffset + , getUTCDate, getUTCDay, getUTCFullYear + , getUTCHours, getUTCMilliseconds + , getUTCMinutes, getUTCMonth, getUTCSeconds + , parseDate + , setDate, setFullYear, setHours + , setMilliseconds, setMinutes, setMonth + , setSeconds, setTime + , setUTCDate, setUTCFullYear, setUTCHours + , setUTCMilliseconds, setUTCMinutes, setUTCMonth + , setUTCSeconds, toDateString + , toISOString, toJSON + , toLocaleDateString, toLocaleTimeString + , toLocaleString, toString + , toTimeString, toUTCString + ) where + +import Data.Boolean ( BooleanOf, IfB(..), EqB(..) ) + +import Language.Sunroof.Classes ( Sunroof(..), SunroofArgument(..) ) +import Language.Sunroof.Types ( JS, invoke, new, cast ) +import Language.Sunroof.JS.Object ( JSObject ) +import Language.Sunroof.JS.Number ( JSNumber ) +import Language.Sunroof.JS.String ( JSString ) +import Language.Sunroof.JS.Bool ( JSBool, jsIfB ) + +-- ------------------------------------------------------------- +-- JSDate Type +-- ------------------------------------------------------------- + +-- | The type of a date object. +newtype JSDate = JSDate JSObject + +-- | Show the Javascript. +instance Show JSDate where + show (JSDate o) = show o + +-- | First-class values in Javascript. +instance Sunroof JSDate where + box = JSDate . box + unbox (JSDate o) = unbox o + +-- | Associated boolean is 'JSBool'. +type instance BooleanOf JSDate = JSBool + +-- | Can be returned in branches. +instance IfB JSDate where + ifB = jsIfB + +-- | Reference equality, not value equality. +instance EqB JSDate where + (JSDate a) ==* (JSDate b) = a ==* b + +-- ------------------------------------------------------------- +-- JSDate Methods +-- ------------------------------------------------------------- + +-- | Creates a new @Date@ object. +-- See: +newDate :: (SunroofArgument a) => a -> JS t JSDate +newDate args = cast `fmap` new "Date" args + +-- | Returns the hour (from 0-23). +-- See: +getHours :: JSDate -> JS t JSNumber +getHours = invoke "getHours" () + +-- | Returns the minutes (from 0-59). +-- See: +getMinutes :: JSDate -> JS t JSNumber +getMinutes = invoke "getMinutes" () + +-- | Returns the seconds (from 0-59). +-- See: +getSeconds :: JSDate -> JS t JSNumber +getSeconds = invoke "getSeconds" () + +-- | Returns the day of the month (from 1-31). +-- See: +getDate :: JSDate -> JS t JSNumber +getDate = invoke "getDate" () + +-- | Returns the day of the week (from 0-6). +-- See: +getDay :: JSDate -> JS t JSNumber +getDay = invoke "getDay" () + +-- | Returns the year (four digits). +-- See: +getFullYear :: JSDate -> JS t JSNumber +getFullYear = invoke "getFullYear" () + +-- | Returns the milliseconds (from 0-999). +-- See: +getMilliseconds :: JSDate -> JS t JSNumber +getMilliseconds = invoke "getMilliseconds" () + +-- | Returns the month (from 0-11). +-- See: +getMonth :: JSDate -> JS t JSNumber +getMonth = invoke "getMonth" () + +-- | Returns the number of milliseconds since midnight Jan 1, 1970. +-- See: +getTime :: JSDate -> JS t JSNumber +getTime = invoke "getTime" () + +-- | Returns the time difference between UTC time and local time, in minutes. +-- See: +getTimezoneOffset :: JSDate -> JS t JSNumber +getTimezoneOffset = invoke "getTimezoneOffset" () + +-- | Returns the day of the month, according to universal time (from 1-31). +-- See: +getUTCDate :: JSDate -> JS t JSNumber +getUTCDate = invoke "getUTCDate" () + +-- | Returns the day of the week, according to universal time (from 0-6). +-- See: +getUTCDay :: JSDate -> JS t JSNumber +getUTCDay = invoke "getUTCDay" () + +-- | Returns the year, according to universal time (four digits). +-- See: +getUTCFullYear :: JSDate -> JS t JSNumber +getUTCFullYear = invoke "getUTCFullYear" () + +-- | Returns the hour, according to universal time (from 0-23). +-- See: +getUTCHours :: JSDate -> JS t JSNumber +getUTCHours = invoke "getUTCHours" () + +-- | Returns the milliseconds, according to universal time (from 0-999). +-- See: +getUTCMilliseconds :: JSDate -> JS t JSNumber +getUTCMilliseconds = invoke "getUTCMilliseconds" () + +-- | Returns the minutes, according to universal time (from 0-59). +-- See: +getUTCMinutes :: JSDate -> JS t JSNumber +getUTCMinutes = invoke "getUTCMinutes" () + +-- | Returns the month, according to universal time (from 0-11). +-- See: +getUTCMonth :: JSDate -> JS t JSNumber +getUTCMonth = invoke "getUTCMonth" () + +-- | Returns the seconds, according to universal time (from 0-59). +-- See: +getUTCSeconds :: JSDate -> JS t JSNumber +getUTCSeconds = invoke "getUTCSeconds" () + +-- | Parses a date string and returns the number of milliseconds +-- since midnight of January 1, 1970. +-- See: +parseDate :: JSString -> JSDate -> JS t JSNumber +parseDate str = invoke "parse" str + +-- | Sets the day of the month of a date object. +-- See: +setDate :: JSNumber -> JSDate -> JS t () +setDate n = invoke "setDate" n + +-- | Sets the year (four digits) of a date object. +-- See: +setFullYear :: JSNumber -> JSDate -> JS t () +setFullYear n = invoke "setFullYear" n + +-- | Sets the hour of a date object. +-- See: +setHours :: JSNumber -> JSDate -> JS t () +setHours n = invoke "setHours" n + +-- | Sets the milliseconds of a date object. +-- See: +setMilliseconds :: JSNumber -> JSDate -> JS t () +setMilliseconds n = invoke "setMilliseconds" n + +-- | Set the minutes of a date object. +-- See: +setMinutes :: JSNumber -> JSDate -> JS t () +setMinutes n = invoke "setMinutes" n + +-- | Sets the month of a date object. +-- See: +setMonth :: JSNumber -> JSDate -> JS t () +setMonth n = invoke "setMonth" n + +-- | Sets the seconds of a date object. +-- See: +setSeconds :: JSNumber -> JSDate -> JS t () +setSeconds n = invoke "setSeconds" n + +-- | Sets a date and time by adding or subtracting a specified number +-- of milliseconds to/from midnight January 1, 1970. +-- See: +setTime :: JSNumber -> JSDate -> JS t () +setTime n = invoke "setTime" n + +-- | Sets the day of the month of a date object, according to universal time. +-- See: +setUTCDate :: JSNumber -> JSDate -> JS t () +setUTCDate n = invoke "setUTCDate" n + +-- | Sets the year of a date object, according to universal time (four digits). +-- See: +setUTCFullYear :: JSNumber -> JSDate -> JS t () +setUTCFullYear n = invoke "setUTCFullYear" n + +-- | Sets the hour of a date object, according to universal time. +-- See: +setUTCHours :: JSNumber -> JSDate -> JS t () +setUTCHours n = invoke "setUTCHours" n + +-- | Sets the milliseconds of a date object, according to universal time. +-- See: +setUTCMilliseconds :: JSNumber -> JSDate -> JS t () +setUTCMilliseconds n = invoke "setUTCMilliseconds" n + +-- | Set the minutes of a date object, according to universal time. +-- See: +setUTCMinutes :: JSNumber -> JSDate -> JS t () +setUTCMinutes n = invoke "setUTCMinutes" n + +-- | Sets the month of a date object, according to universal time. +-- See: +setUTCMonth :: JSNumber -> JSDate -> JS t () +setUTCMonth n = invoke "setUTCMonth" n + +-- | Set the seconds of a date object, according to universal time. +-- See: +setUTCSeconds :: JSNumber -> JSDate -> JS t () +setUTCSeconds n = invoke "setUTCSeconds" n + +-- | Converts the date portion of a Date object into a readable string. +-- See: +toDateString :: JSDate -> JS t JSString +toDateString = invoke "toDateString" () + +-- | Returns the date as a string, using the ISO standard. +-- See: +toISOString :: JSDate -> JS t JSString +toISOString = invoke "toISOString" () + +-- | Returns the date as a string, formated as a JSON date. +-- See: +toJSON :: JSDate -> JS t JSString +toJSON = invoke "toJSON" () + +-- | Returns the date portion of a Date object as a string, +-- using locale conventions. +-- See: +toLocaleDateString :: JSDate -> JS t JSString +toLocaleDateString = invoke "toLocaleDateString" () + +-- | Returns the time portion of a Date object as a string, +-- using locale conventions. +-- See: +toLocaleTimeString :: JSDate -> JS t JSString +toLocaleTimeString = invoke "toLocaleTimeString" () + +-- | Converts a Date object to a string, using locale conventions. +-- See: +toLocaleString :: JSDate -> JS t JSString +toLocaleString = invoke "toLocaleString" () + +-- | Converts a Date object to a string. +-- See: +toString :: JSDate -> JS t JSString +toString = invoke "toString" () + +-- | Converts the time portion of a Date object to a string. +-- See: +toTimeString :: JSDate -> JS t JSString +toTimeString = invoke "toTimeString" () + +-- | Converts a Date object to a string, according to universal time. +-- See: +toUTCString :: JSDate -> JS t JSString +toUTCString = invoke "toUTCString" () + diff --git a/Language/Sunroof/JS/JQuery.hs b/Language/Sunroof/JS/JQuery.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/JS/JQuery.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE DataKinds #-} + +-- | This module provides parts of the JQuery API (). +module Language.Sunroof.JS.JQuery + ( + -- * General JQuery API + dollar + , jQuery, jq + -- * DOM + , append + , html, setHtml + , text, setText + -- * CSS + , css, setCss + , addClass, removeClass + -- * Attributes + , attribute, attr' + , setAttr + , removeAttr + -- * Event Handling + , on + -- * Manipulation + , innerWidth + , innerHeight + , outerWidth, outerWidth' + , outerHeight, outerHeight' + , clone, clone' + ) where + +import Language.Sunroof.Classes + ( SunroofArgument(..) + ) +import Language.Sunroof.Types + +import Language.Sunroof.JS.Object ( JSObject ) +import Language.Sunroof.JS.String ( JSString ) +import Language.Sunroof.JS.Number ( JSNumber ) +import Language.Sunroof.JS.Bool ( JSBool ) + +-- ----------------------------------------------------------------------- +-- JQuery interface +-- ----------------------------------------------------------------------- + +-- | The dollar function. +-- See . +dollar :: JSFunction JSString JSObject +dollar = fun "$" + +-- | Calls the JQuery dollar function. +-- See . +jQuery :: JSString -> JS t JSObject +jQuery nm = dollar `apply` nm + +-- | Short-hand for 'jQuery'. +jq :: JSString -> JS t JSObject +jq = jQuery + +-- ----------------------------------------------------------------------- +-- Manipulation > DOM +-- ----------------------------------------------------------------------- + +-- | See . +append :: JSObject -> JSObject -> JS t () +append x = invoke "append" x + +-- | See @.html()@ at . +html :: JSObject -> JS t JSObject +html = invoke "html" () + +-- | See @.html(htmlString)@ at . +setHtml :: JSString -> JSObject -> JS t JSObject +setHtml s = invoke "html" s + +-- | See @.text()@ at . +text :: JSObject -> JS t JSObject +text = invoke "text" () + +-- | See @.text(textString)@ at . +setText :: JSString -> JSObject -> JS t JSObject +setText s = invoke "text" s + +-- ------------------------------------------------------------- +-- CSS +-- ------------------------------------------------------------- + +-- | See @.css(propertyName)@ at . +css :: JSString -> JSObject -> JS t JSString +css prop = invoke "css" prop + +-- | See @.css(propertyName, value)@ at . +setCss :: JSString -> JSString -> JSObject -> JS t JSString +setCss prop v = invoke "css" (prop, v) + +-- | See . +addClass :: JSString -> JSObject -> JS t () +addClass = invoke "addClass" + +-- | See . +removeClass :: JSString -> JSObject -> JS t () +removeClass = invoke "removeClass" + +-- ------------------------------------------------------------- +-- Attributes +-- ------------------------------------------------------------- + +-- | See @.attr(attributeName)@ at . +-- This binding does not have the original Javascript name, +-- because of the 'attr' function. +attribute :: JSString -> JSObject -> JS t JSString +attribute a = invoke "attr" a + +-- | See @.attr(attributeName)@ at . +-- This binding does not have the original Javascript name, +-- because of the 'attr' function. +attr' :: JSString -> JSObject -> JS t JSString +attr' = attribute + +-- | See @.attr(attributeName, value)@ at . +setAttr :: JSString -> JSString -> JSObject -> JS t JSString +setAttr a v = invoke "attr" (a, v) + +-- | See: +removeAttr :: JSString -> JSObject -> JS t JSObject +removeAttr attrName = invoke "removeAttr" attrName + +-- ------------------------------------------------------------- +-- Event Handling +-- ------------------------------------------------------------- + +-- | See . +on :: (SunroofArgument a) => JSString -> JSString -> (a -> JS B ()) -> JSObject -> JS t () +on nm sel f o = do + callback <- continuation f + o # invoke "on" (nm,sel,callback) + +-- ------------------------------------------------------------- +-- Manipulation > Style Properties +-- ------------------------------------------------------------- + +-- | See . +innerWidth :: JSObject -> JS t JSNumber +innerWidth = invoke "innerWidth" () + +-- | See . +innerHeight :: JSObject -> JS t JSNumber +innerHeight = invoke "innerHeight" () + +-- | See . +outerWidth :: JSObject -> JS t JSNumber +outerWidth = invoke "outerWidth" () + +-- | See . +outerWidth' :: JSBool -> JSObject -> JS t JSNumber +outerWidth' includeMargin = invoke "outerWidth" includeMargin + +-- | See . +outerHeight :: JSObject -> JS t JSNumber +outerHeight = invoke "outerHeight" () + +-- | See . +outerHeight' :: JSBool -> JSObject -> JS t JSNumber +outerHeight' includeMargin = invoke "outerHeight" includeMargin + +-- | See @.clone()@ at . +clone :: JSObject -> JS t JSObject +clone = invoke "clone" () + +-- | See @.clone(withDataAndEvents, deepWithDataAndEvents)@ at . +clone' :: JSBool -> JSBool -> JSObject -> JS t JSObject +clone' withDataAndEvents deepWithDataAndEvents = + invoke "clone" (withDataAndEvents, deepWithDataAndEvents) + + diff --git a/Language/Sunroof/JS/MVar.hs b/Language/Sunroof/JS/MVar.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/JS/MVar.hs @@ -0,0 +1,120 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-methods #-} + +-- | 'JSMVar' provides the same functionality and +-- concurrency abstraction in Javascript computations +-- as 'Control.Concurrent.MVar' in Haskell. +module Language.Sunroof.JS.MVar + ( JSMVar + , newMVar, newEmptyMVar + , putMVar, takeMVar + ) where + +import Data.Boolean ( IfB(..), EqB(..) ) + +import Language.Sunroof.Classes + ( Sunroof(..), SunroofArgument(..) ) +import Language.Sunroof.Types +import Language.Sunroof.Concurrent ( forkJS ) +import Language.Sunroof.Selector ( (!) ) +import Language.Sunroof.TH +import Language.Sunroof.JS.Object ( JSObject ) +import Language.Sunroof.JS.Array + ( JSArray + , newArray, length' + , push, shift ) + +-- ------------------------------------------------------------- +-- JSMVar Type +-- ------------------------------------------------------------- + +-- | 'JSMVar' abstraction. The type parameter gives +-- the type of values held in a 'JSMVar'. +newtype JSMVar a = JSMVar JSObject + +deriveJSTuple + [d| instance (SunroofArgument o) => JSTuple (JSMVar o) where + type Internals (JSMVar o) = + ( (JSArray (JSContinuation (JSContinuation o))) -- callbacks of written data + , (JSArray (JSContinuation o)) -- callbacks of waiting readers + ) + |] + +-- | Reference equality, not value equality. +instance (SunroofArgument o) => EqB (JSMVar o) where + (JSMVar a) ==* (JSMVar b) = a ==* b + +-- ------------------------------------------------------------- +-- JSMVar Combinators +-- ------------------------------------------------------------- + +-- | Create a new 'JSMVar' with the given value inside. +-- See 'newEmptyMVar'. +newMVar :: forall a t . (SunroofArgument a) => a -> JS t (JSMVar a) +newMVar a = do + written <- newArray () + waiting <- newArray () + -- mvar must be empty, with no one waiting, so just push and continue + f <- continuation $ \ (k :: JSContinuation a) -> goto k a :: JSB () + written # push (f :: JSContinuation (JSContinuation a)) + tuple (written, waiting) + +-- | Create a new empty 'JSMVar'. +-- See 'newMVar'. +newEmptyMVar :: (SunroofArgument a) => JS t (JSMVar a) +newEmptyMVar = do + written <- newArray () + waiting <- newArray () + tuple (written, waiting) + +-- TODO: Not quite right; pauses until someone bites +-- | Put the value into the 'JSMVar'. If there already is a +-- value inside, this will block until it is taken out. +putMVar :: forall a . (SunroofArgument a) => a -> JSMVar a -> JS B () +putMVar a (match -> (written,waiting)) = do + ifB ((waiting ! length') ==* 0) + (-- no-one is waiting, so check for fullness + ifB ((written ! length') ==* 0) + (-- mvar empty, so just push and continue + do f <- continuation $ \ (k :: JSContinuation a) -> goto k a :: JSB () + written # push (f :: JSContinuation (JSContinuation a)) + ) + (-- mvar full, so block + callcc $ \ (k :: JSContinuation ()) -> do + f <- continuation $ \ (kr :: JSContinuation a) -> do + -- we've got a request for the contents + -- so we can continue + forkJS $ (goto k () :: JSB ()) + -- and send the boxed value + goto kr a :: JSB () + written # push (f :: JSContinuation (JSContinuation a)) + done + ) + ) + -- If someone is already waiting, then just pass the value (and continue without pausing) + (do f <- shift waiting + forkJS (goto f a :: JSB ()) + return () + ) + +-- | Take the value out of the 'JSMVar'. If there is no value +-- inside, this will block until one is available. +takeMVar :: forall a . (Sunroof a, SunroofArgument a) => JSMVar a -> JS B a +takeMVar (match -> (written,waiting)) = do + ifB ((written ! length') ==* 0) + (do -- Add yourself to the 'waiting for writer' Q. + callcc $ \ k -> do waiting # push (k :: JSContinuation a) + done + ) + (do f <- shift written + -- Here, we add our continuation into the written Q. + callcc $ \ k -> goto f k + ) + + diff --git a/Language/Sunroof/JS/Map.hs b/Language/Sunroof/JS/Map.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/JS/Map.hs @@ -0,0 +1,73 @@ + +{-# LANGUAGE TypeFamilies #-} + +-- | 'JSMap' provides an abstract and more type-safe access to maps +-- in JavaScript. It is a wrapper around the dictionary each object +-- in JavaScript is. +module Language.Sunroof.JS.Map + ( JSMap + , newMap + , insert + , lookup' + , size + ) where + +import Data.Boolean ( IfB(..), BooleanOf ) + +import Language.Sunroof.Classes + ( Sunroof(..) ) +import Language.Sunroof.Types +import Language.Sunroof.Selector ( (!) ) +import Language.Sunroof.JS.Object ( JSObject ) +import Language.Sunroof.JS.Bool ( JSBool, jsIfB ) +import Language.Sunroof.JS.Number + +-- ------------------------------------------------------------- +-- JSMap Type +-- ------------------------------------------------------------- + +-- | 'JSMap' abstraction. The first type parameter gives +-- the type of keys used by the name and the second gives +-- the type of values. +newtype JSMap k a = JSMap JSObject + +instance (SunroofKey k, Sunroof a) => Show (JSMap k a) where + show (JSMap o) = show o + +instance (SunroofKey k, Sunroof a) => Sunroof (JSMap k a) where + box = JSMap . box + unbox (JSMap o) = unbox o + +type instance BooleanOf (JSMap k a) = JSBool + +instance (SunroofKey k, Sunroof a) => IfB (JSMap k a) where + ifB = jsIfB + +-- ------------------------------------------------------------- +-- JSMap Combinators +-- ------------------------------------------------------------- + +-- | Create a new empty 'JSMap'. +newMap :: JS t (JSMap k a) +newMap = do + o <- new "Object" () + return $ JSMap o + +-- | @insert k x@ inserts an element @x@ associated with the given +-- key @k@ into a map. +insert :: (SunroofKey k, Sunroof a) => k -> a -> JSMap k a -> JS t () +insert k a (JSMap o) = do + o # jsKey k := a + +-- | @lookup k@ selects the value associated with the key @k@. +lookup' :: (SunroofKey k, Sunroof a) => k -> JSMap k a -> JS t a +lookup' k (JSMap o) = do + evaluate $ o ! jsKey k + +size :: JSMap k a -> JS t JSNumber +size (JSMap o) = fun "Object.size" $$ o + +--deleteMap :: (SunroofKey k, Sunroof a) => k -> JSMap k a -> JS t () +--deleteMap k (JSMap o) = fun "delete" $$ (o ! jsKey k) + + diff --git a/Language/Sunroof/JS/Number.hs b/Language/Sunroof/JS/Number.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/JS/Number.hs @@ -0,0 +1,158 @@ + +{-# LANGUAGE TypeFamilies #-} + +-- | Numbers in Javascript. +module Language.Sunroof.JS.Number + ( JSNumber + , int + ) where + +import Prelude hiding (div, mod, quot, rem, floor, ceiling, isNaN, isInfinite) + +import Data.Boolean ( BooleanOf, Boolean(..), IfB(..), EqB(..), OrdB(..) ) +import Data.Boolean.Numbers + ( NumB(..) + , RealFloatB(..), RealFracB(..) + , IntegralB(..), fromIntegralB ) +import Data.AdditiveGroup ( AdditiveGroup(..) ) +import Data.VectorSpace ( VectorSpace(..) ) +import Data.Ratio ( Ratio ) + +import Language.Sunroof.Internal ( litparen ) +import Language.Sunroof.JavaScript ( Expr, showExpr, uniOp, binOp, literal ) +import Language.Sunroof.Classes ( Sunroof(..), SunroofValue(..) ) +import Language.Sunroof.JS.Bool ( JSBool, jsIfB ) + +-- ------------------------------------------------------------- +-- JSNumber Type +-- ------------------------------------------------------------- + +-- | Type of numbers in Javascript. +data JSNumber = JSNumber Expr + +-- | Show the Javascript +instance Show JSNumber where + show (JSNumber v) = showExpr False v + +-- | First-class values in Javascript. +instance Sunroof JSNumber where + box = JSNumber + unbox (JSNumber e) = e + +instance Num JSNumber where + (JSNumber e1) + (JSNumber e2) = box $ binOp "+" e1 e2 + (JSNumber e1) - (JSNumber e2) = box $ binOp "-" e1 e2 + (JSNumber e1) * (JSNumber e2) = box $ binOp "*" e1 e2 + abs (JSNumber e1) = box $ uniOp "Math.abs" e1 + signum (JSNumber _e1) = error "signum" -- JSNumber $ uniOp "ERROR" e1 + fromInteger = box . literal . litparen . show + +instance NumB JSNumber where + type IntegerOf JSNumber = JSNumber + fromIntegerB = id + +instance IntegralB JSNumber where + quot a b = ifB ((a / b) <* 0) + (box $ uniOp "Math.ceil" (unbox $ a / b)) + (a `div` b) + rem a b = a - (a `quot` b)*b + div a b = box $ uniOp "Math.floor" (unbox $ a / b) + mod (JSNumber a) (JSNumber b) = box $ binOp "%" a b + toIntegerB = id + + +instance Fractional JSNumber where + (JSNumber e1) / (JSNumber e2) = box $ binOp "/" e1 e2 + fromRational = box . literal . litparen . show . (fromRational :: Rational -> Double) + +instance Floating JSNumber where + pi = box $ literal $ "Math.PI" + sin (JSNumber e) = box $ uniOp "Math.sin" e + cos (JSNumber e) = box $ uniOp "Math.cos" e + asin (JSNumber e) = box $ uniOp "Math.asin" e + acos (JSNumber e) = box $ uniOp "Math.acos" e + atan (JSNumber e) = box $ uniOp "Math.atan" e + sinh (JSNumber e) = box $ uniOp "Math.sinh" e + cosh (JSNumber e) = box $ uniOp "Math.cosh" e + asinh (JSNumber e) = box $ uniOp "Math.asinh" e + acosh (JSNumber e) = box $ uniOp "Math.acosh" e + atanh (JSNumber e) = box $ uniOp "Math.atanh" e + exp (JSNumber e) = box $ uniOp "Math.exp" e + log (JSNumber e) = box $ uniOp "Math.log" e + +instance RealFracB JSNumber where + properFraction n = + ( fromIntegralB $ ifB (n >=* 0) (floor n :: JSNumber) (ceiling n :: JSNumber) + , ifB (n >=* 0) (n - floor n) (n - ceiling n) + ) + round (JSNumber e) = fromIntegralB $ JSNumber $ uniOp "Math.round" e + ceiling (JSNumber e) = fromIntegralB $ JSNumber $ uniOp "Math.ceil" e + floor (JSNumber e) = fromIntegralB $ JSNumber $ uniOp "Math.floor" e + +instance RealFloatB JSNumber where + isNaN (JSNumber a) = box $ uniOp "isNaN" a + isInfinite n = notB (isFinite n) &&* notB (isNaN n) + where isFinite (JSNumber a) = box $ uniOp "isFinite" a + isNegativeZero n = isInfinite n &&* n <* 0 + isIEEE _ = true -- AFAIK + atan2 (JSNumber a) (JSNumber b) = box $ binOp "Math.atan2" a b + +type instance BooleanOf JSNumber = JSBool + +instance IfB JSNumber where + ifB = jsIfB + +instance EqB JSNumber where + (==*) e1 e2 = box $ binOp "==" (unbox e1) (unbox e2) + (/=*) e1 e2 = box $ binOp "!=" (unbox e1) (unbox e2) + +instance OrdB JSNumber where + (>*) e1 e2 = box $ binOp ">" (unbox e1) (unbox e2) + (>=*) e1 e2 = box $ binOp ">=" (unbox e1) (unbox e2) + (<*) e1 e2 = box $ binOp "<" (unbox e1) (unbox e2) + (<=*) e1 e2 = box $ binOp "<=" (unbox e1) (unbox e2) + +instance AdditiveGroup JSNumber where + zeroV = 0 + (^+^) = (+) + negateV = negate + +instance VectorSpace JSNumber where + type Scalar JSNumber = JSNumber + s *^ d = s * d + +instance SunroofValue Double where + type ValueOf Double = JSNumber + js = box . literal . litparen . show + +instance SunroofValue Float where + type ValueOf Float = JSNumber + js = box . literal . litparen . show + +instance SunroofValue Int where + type ValueOf Int = JSNumber + js = fromInteger . toInteger + +instance SunroofValue Integer where + type ValueOf Integer = JSNumber + js = fromInteger . toInteger + +instance (Integral a) => SunroofValue (Ratio a) where + type ValueOf (Ratio a) = JSNumber + js = box . literal . litparen . (show :: Double -> String) . fromRational . toRational + +-- ------------------------------------------------------------- +-- JSNumber Combinators +-- ------------------------------------------------------------- + +-- | A explicit cast to int. +int :: (Sunroof a) => a -> JSNumber +int = box . uniOp "(int)" . unbox + + + + + + + + diff --git a/Language/Sunroof/JS/Object.hs b/Language/Sunroof/JS/Object.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/JS/Object.hs @@ -0,0 +1,52 @@ + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Abstraction over the most general type in Javascript. +module Language.Sunroof.JS.Object + ( JSObject + , object + , this + ) where + +import Data.Boolean ( BooleanOf, IfB(..), EqB(..) ) + +import Language.Sunroof.JavaScript ( Expr, showExpr, literal, binOp ) +import Language.Sunroof.Classes ( Sunroof(..) ) +import Language.Sunroof.JS.Bool ( JSBool, jsIfB ) + +-- ------------------------------------------------------------- +-- JSObject Type +-- ------------------------------------------------------------- + +-- | Data type for all Javascript objects. +data JSObject = JSObject Expr + +instance Show JSObject where + show (JSObject v) = showExpr False v + +instance Sunroof JSObject where + box = JSObject + unbox (JSObject o) = o + +type instance BooleanOf JSObject = JSBool + +instance IfB JSObject where + ifB = jsIfB + +-- | Reference equality, not value equality. +instance EqB JSObject where + (JSObject a) ==* (JSObject b) = box $ binOp "==" a b + +-- ------------------------------------------------------------- +-- JSObject Combinators +-- ------------------------------------------------------------- + +-- | Create an arbitrary object from a literal in form of a string. +object :: String -> JSObject +object = box . literal + +-- | The @this@ reference. +this :: JSObject +this = object "this" diff --git a/Language/Sunroof/JS/Ref.hs b/Language/Sunroof/JS/Ref.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/JS/Ref.hs @@ -0,0 +1,69 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module provides the equivalent of a 'IORef' in the Sunroof world. +module Language.Sunroof.JS.Ref + ( JSRef + , newJSRef + , readJSRef + , writeJSRef + , modifyJSRef + ) where + +import Data.Boolean ( BooleanOf, IfB(..), EqB(..) ) + +import Language.Sunroof.Classes ( Sunroof(..) ) +import Language.Sunroof.Types ( T(..), JS(..), evaluate, new, (#), liftJS ) +import Language.Sunroof.Selector ( (!) ) +import Language.Sunroof.JS.Object ( JSObject ) +import Language.Sunroof.JS.Bool ( JSBool, jsIfB ) + +-- ------------------------------------------------------------- +-- JSRef Type +-- ------------------------------------------------------------- + +-- | This is the 'IORef' of Sunroof. +newtype JSRef a = JSRef JSObject + +instance (Sunroof a) => Show (JSRef a) where + show (JSRef o) = show o + +instance (Sunroof a) => Sunroof (JSRef a) where + box = JSRef . box + unbox (JSRef o) = unbox o + +type instance BooleanOf (JSRef a) = JSBool + +instance (Sunroof a) => IfB (JSRef a) where + ifB = jsIfB + +-- | Reference equality, not value equality. +instance (Sunroof a) => EqB (JSRef a) where + (JSRef a) ==* (JSRef b) = a ==* b + +-- ------------------------------------------------------------- +-- JSRef Combinators +-- ------------------------------------------------------------- + +-- | Create a new 'JSRef' with the given intial value. +newJSRef :: (Sunroof a) => a -> JS t (JSRef a) +newJSRef a = do + obj <- new "Object" () + obj # "val" := a + return $ JSRef obj + +-- | Non-blocking read of a 'JSRef'. +readJSRef :: (Sunroof a) => JSRef a -> JS t a +readJSRef (JSRef obj) = evaluate $ obj ! "val" + +-- | Non-blocking write of a 'JSRef'. +writeJSRef :: (Sunroof a) => a -> JSRef a -> JS t () +writeJSRef a (JSRef obj) = obj # "val" := a + +-- | Non-blocking modification of a 'JSRef'. +modifyJSRef :: (Sunroof a) => (a -> JS A a) -> JSRef a -> JS t () +modifyJSRef f ref = do + val <- readJSRef ref + liftJS (f val) >>= \ v -> ref # writeJSRef v diff --git a/Language/Sunroof/JS/String.hs b/Language/Sunroof/JS/String.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/JS/String.hs @@ -0,0 +1,119 @@ + +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Strings in Javascript. +module Language.Sunroof.JS.String + ( JSString + , string + ) where + +import Data.Boolean ( BooleanOf, IfB(..), EqB(..) ) +import Data.Monoid ( Monoid(..) ) +import Data.Semigroup ( Semigroup(..) ) +import Data.Char ( isAscii, isControl, ord ) +import Data.String ( IsString(..) ) + +import Numeric ( showHex ) + +import Language.Sunroof.JavaScript ( Expr, showExpr, binOp, literal ) +import Language.Sunroof.Classes ( Sunroof(..), SunroofValue(..) ) +import Language.Sunroof.JS.Bool ( JSBool, jsIfB ) + +-- ------------------------------------------------------------- +-- JSString Type +-- ------------------------------------------------------------- + +-- | Javascript string type. +data JSString = JSString Expr + +-- | Show the Javascript. +instance Show JSString where + show (JSString v) = showExpr False v + +-- | First-class Javascript value. +instance Sunroof JSString where + box = JSString + unbox (JSString e) = e + +-- | Semigroup under concatination. +instance Semigroup JSString where + (JSString e1) <> (JSString e2) = box $ binOp "+" e1 e2 + +-- | Monoid under concatination and empty string. +instance Monoid JSString where + mempty = fromString "" + mappend (JSString e1) (JSString e2) = box $ binOp "+" e1 e2 + +-- | Create them from Haskell 'String's. +instance IsString JSString where + fromString = box . literal . jsLiteralString + +type instance BooleanOf JSString = JSBool + +instance IfB JSString where + ifB = jsIfB + +-- | Value equality. +instance EqB JSString where + (==*) e1 e2 = box $ binOp "==" (unbox e1) (unbox e2) + (/=*) e1 e2 = box $ binOp "!=" (unbox e1) (unbox e2) + +-- | Create a 'JSString' from a 'String'. +instance SunroofValue [Char] where + type ValueOf [Char] = JSString + js = fromString + +-- | Create a single character 'JSString' from a 'Char'. +instance SunroofValue Char where + type ValueOf Char = JSString + js c = fromString [c] + +-- ------------------------------------------------------------- +-- JSString Combinators +-- ------------------------------------------------------------- + +-- | Create a Javascript string from a Haskell string. +string :: String -> JSString +string = fromString + +-- ------------------------------------------------------------- +-- String Conversion Utilities: Haskell -> JS +-- ------------------------------------------------------------- + +-- | Transform a Haskell string into a string representing a JS string literal. +jsLiteralString :: String -> String +jsLiteralString = jsQuoteString . jsEscapeString + +-- | Add quotes to a string. +jsQuoteString :: String -> String +jsQuoteString s = "\"" ++ s ++ "\"" + +-- | Transform a character to a string that represents its JS +-- unicode escape sequence. +jsUnicodeChar :: Char -> String +jsUnicodeChar c = + let hex = showHex (ord c) "" + in ('\\':'u': replicate (4 - length hex) '0') ++ hex + +-- | Correctly replace Haskell characters by the JS escape sequences. +jsEscapeString :: String -> String +jsEscapeString [] = [] +jsEscapeString (c:cs) = case c of + -- Backslash has to remain backslash in JS. + '\\' -> '\\' : '\\' : jsEscapeString cs + -- Special control sequences. + '\0' -> jsUnicodeChar '\0' ++ jsEscapeString cs -- Ambigous with numbers + '\a' -> jsUnicodeChar '\a' ++ jsEscapeString cs -- Non JS + '\b' -> '\\' : 'b' : jsEscapeString cs + '\f' -> '\\' : 'f' : jsEscapeString cs + '\n' -> '\\' : 'n' : jsEscapeString cs + '\r' -> '\\' : 'r' : jsEscapeString cs + '\t' -> '\\' : 't' : jsEscapeString cs + '\v' -> '\\' : 'v' : jsEscapeString cs + '\"' -> '\\' : '\"' : jsEscapeString cs + '\'' -> '\\' : '\'' : jsEscapeString cs + -- Non-control ASCII characters can remain as they are. + c' | not (isControl c') && isAscii c' -> c' : jsEscapeString cs + -- All other non ASCII signs are escaped to unicode. + c' -> jsUnicodeChar c' ++ jsEscapeString cs diff --git a/Language/Sunroof/JavaScript.hs b/Language/Sunroof/JavaScript.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/JavaScript.hs @@ -0,0 +1,280 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +-- TODO: Remove as soon as the pretty printing stuff is actually used. +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + +-- | Basic low-level types and their combinators. +-- These are used as output of the compiler. +-- Everything here is untypes and not supposed for public use! +module Language.Sunroof.JavaScript + ( Expr, ExprE(..), E(..) + , Id, Stmt(..), Type(..) + , Rhs(..) + , showExpr, showStmt + , operator, binOp, uniOp + , literal + , scopeForEffect + ) where + +import Data.List ( intercalate ) +import Data.Reify ( MuRef(..) ) +import Control.Applicative ( Applicative, pure, (<$>), (<*>)) +import Data.Traversable ( Traversable(..) ) +import Data.Foldable ( Foldable(..) ) +import Data.Monoid ( Monoid(..) ) +import Data.Char ( isAlpha, isAlphaNum ) + +-- ------------------------------------------------------------- +-- Javascript Expressions +-- ------------------------------------------------------------- + +-- | Javascript identifier. +type Id = String + +-- | Short name for instantiated expressions. +type Expr = E ExprE + +-- | Instantiated expressions. +data ExprE = ExprE Expr deriving Show + +-- | Plain expressions in Javascript. +data E expr = Lit String -- ^ A precompiled (atomic) Javascript literal. + | Var Id -- ^ A variable. + | Dot expr expr Type -- ^ Field/attribute access (with type information): @expr . expr :: Type@ + | Apply expr [expr] -- ^ Function application: @expr ( expr, ..., expr )@ + | Function [Id] [Stmt] -- ^ Anonymous function with parameter names and body. + deriving Show + +instance MuRef ExprE where + type DeRef ExprE = E + mapDeRef f (ExprE e) = traverse f e + +instance Traversable E where + traverse _ (Lit s) = pure (Lit s) + traverse _ (Var s) = pure (Var s) + traverse f (Dot o n a) = Dot <$> f o <*> f n <*> pure a + traverse f (Apply s xs) = Apply <$> f s <*> traverse f xs + traverse _ (Function nms stmts) = pure (Function nms stmts) + +instance Foldable E where + foldMap _ (Lit _) = mempty + foldMap _ (Var _) = mempty + foldMap f (Dot o n _) = f o `mappend` f n + foldMap f (Apply o xs) = f o `mappend` foldMap f xs + foldMap _ (Function _nms _stmts) = mempty + +instance Functor E where + fmap _ (Lit s) = Lit s + fmap _ (Var s) = Var s + fmap f (Dot o n a) = Dot (f o) (f n) a + fmap f (Apply s xs) = Apply (f s) (map f xs) + fmap _ (Function nms stmts) = Function nms stmts + +-- | Show an expression as compiled Javascript. +-- The boolean argument says non-trivial arguments need parenthesis. +showExpr :: Bool -> Expr -> String +-- Original comment: These being up here, cause a GHC warning for missing patterns. +-- So they are moved down. +-- Response: They *need* to be here, it makes a different. I've fixed the warning. +showExpr _ (Lit a) = a -- always stand alone, or pre-parenthesised +showExpr _ (Var v) = v -- always stand alone +showExpr b e = p $ case e of +-- (Apply (ExprE (Var "[]")) [ExprE a,ExprE x]) -> showExpr True a ++ "[" ++ showExpr False x ++ "]" + (Apply (ExprE (Var "?:")) [ExprE a,ExprE x,ExprE y]) -> showExpr True a ++ "?" ++ showExpr True x ++ ":" ++ showExpr True y + (Apply (ExprE (Var op)) [ExprE x,ExprE y]) | not (any isAlpha op) -> showExpr True x ++ op ++ showExpr True y + (Apply (ExprE (Var "!")) [ExprE ex]) -> "!" ++ showExpr True ex + -- We have a constructor call: + (Apply (ExprE (Lit op)) args) | isNewConstructor op -> op ++ showArgs args + (Apply (ExprE fn) args) -> showFun fn args + (Dot (ExprE a) (ExprE x) Base) -> showIdx a x + -- This is a shortcomming in Javascript, where grabbing a indirected function + -- throws away the context (self/this). So we force storage of the context, using a closure. + (Dot (ExprE a) (ExprE x) (Fun xs _)) -> + "function(" ++ intercalate "," args ++ ") { return (" ++ + showIdx a x ++ ")(" ++ intercalate "," args ++ "); }" + where args = [ "a" ++ show i | i <- take (length xs) ([0..] :: [Int])] + -- This pattern was missing too. + (Dot (ExprE _a) (ExprE _x) Unit) -> + error "Dot pattern on unit type. Don't know what to do." + (Function args body) -> + "function" ++ + "(" ++ intercalate "," args ++ ") {\n" ++ + indent 2 (unlines (map showStmt body)) ++ + "}" + _ -> error "should never happen" + where + p txt = if b then "(" ++ txt ++ ")" else txt + +-- | @showIdx o a@ accesses the field/attribute @a@ of the object @o@. +showIdx :: Expr -> Expr -> String +showIdx a (Lit x) | Just n <- isGoodSelectName x + = showExpr True a ++ "." ++ n +showIdx a ix = showExpr True a ++ "[" ++ showExpr False ix ++ "]" + +-- | @showArgs a@ creates a string representing the given expressions +-- in an argument list that can be used for functions or constructors. +showArgs :: [ExprE] -> String +showArgs args = "(" ++ intercalate "," (map (\ (ExprE e') -> showExpr False e') args) ++ ")" + +-- | Show a function application, +showFun :: Expr -> [ExprE] -> String +showFun e args = case e of + (Dot (ExprE a) (ExprE (Lit x)) _) + | Just n <- isGoodSelectName x -> showExpr True a ++ "." ++ n ++ showArgs args + (Dot (ExprE a) (ExprE x) _) -> "(" ++ showIdx a x ++ ")" ++ showArgs args + _ -> showExpr True e ++ showArgs args + +-- | Check if the given 'Id' is a valid Javascript identifier. +isIdentifier :: Id -> Bool +isIdentifier x | not (null x) = isAlpha (head x) && all isAlphaNum (drop 1 x) +isIdentifier _ = False + +-- | Check if the given 'Id' represents a constructor call without +-- arguments. That means a string beginning with @"new "@ followed +-- by a valid identifier ('isIdentifier'). +isNewConstructor :: Id -> Bool +isNewConstructor x = take 4 x == "new " && isIdentifier (drop 4 x) + +-- | Check if the given name is a field/attribute seletor that +-- can be printed without quotes using the dot-notation. +isGoodSelectName :: Id -> Maybe Id +isGoodSelectName xs + | length xs < 2 = Nothing + | head xs == '"' && + last xs == '"' && + all isAlpha xs' = return xs' + | otherwise = Nothing + where + xs' = tail (init xs) + +-- ------------------------------------------------------------- +-- Helper Combinators +-- ------------------------------------------------------------- + +-- | Combinator to create a operator/function applied to the given arguments. +operator :: Id -> [Expr] -> Expr +operator n ps = Apply (ExprE $ Var n) (fmap ExprE ps) + +-- | Short-hand to create the applied binary operator/function. +-- See 'operator'. +binOp :: String -> Expr -> Expr -> E ExprE +binOp o e1 e2 = operator o [e1, e2] + +-- | Short-hand to create the applied unary operator/function. +-- See 'operator'. +uniOp :: String -> Expr -> E ExprE +uniOp o e = operator o [e] + +-- | Combinator to create a expression containing a +-- literal in form of a string. +literal :: String -> Expr +literal = Lit + +-- | Indent all lines of the given string by the given number +-- of spaces. +indent :: Int -> String -> String +indent n = unlines . map (take n (cycle " ") ++) . lines + +-- | Create a anonymous function to scope all effects +-- in the given block of statement. +scopeForEffect :: [Stmt] -> Expr +scopeForEffect stmts = Apply (ExprE $ Function [] stmts) [] + +-- ------------------------------------------------------------- +-- Javascript References +-- ------------------------------------------------------------- + +-- | A Right hand side of an assignment. + +data Rhs = VarRhs Id -- ^ A variable + | DotRhs Expr Expr -- ^ a named field + +showRhs :: Rhs -> String +showRhs (VarRhs var) = "var " ++ var +showRhs (DotRhs e1 e2) = showIdx e1 e2 + +-- ------------------------------------------------------------- +-- Javascript Statements +-- ------------------------------------------------------------- + +-- TODO: remove VarStmt, replace with AssignStmt and ExprStmt. +-- TODO: add type to return stmt; should not return "null" + +-- | Plain Javascript statements. +data Stmt = AssignStmt Rhs Expr -- ^ Restricted assignment: @Rhs = Expr;@ + | DeleteStmt Expr -- ^ Delete reference @delete Rhs;@ + | ExprStmt Expr -- ^ Expression statement, for the sake of its side effects: @Expr;@ + | ReturnStmt Expr -- ^ Return statement: @return Expr;@ + | IfStmt Expr [Stmt] [Stmt] -- ^ If-Then-Else statement: @if (Expr) { Stmts } else { Stmts }@ + | WhileStmt Expr [Stmt] -- ^ While loop: @while (Expr) { Stmts }@ + | CommentStmt String -- ^ A comment in the code: @// String@ + +instance Show Stmt where + show = showStmt + +-- | Translate a statement into actual Javascript. +showStmt :: Stmt -> String +showStmt (AssignStmt e1 e2) = showRhs e1 ++ " = " ++ showExpr False e2 ++ ";" +showStmt (DeleteStmt e) = "delete " ++ showExpr False e ++ ";" +showStmt (ExprStmt e) = showExpr False e ++ ";" +showStmt (ReturnStmt e) = "return " ++ showExpr False e ++ ";" +showStmt (IfStmt i t e) = "if(" ++ showExpr False i ++ "){\n" + ++ indent 2 (unlines (map showStmt t)) + ++ "} else {\n" + ++ indent 2 (unlines (map showStmt e)) + ++ "}" +showStmt (WhileStmt b stmts) = "while(" ++ showExpr False b ++ "){\n" + ++ indent 2 (unlines (map showStmt stmts)) + ++ "}" +showStmt (CommentStmt msg) = "/* " ++ msg ++ " */" + +-- ------------------------------------------------------------- +-- Javascript Types +-- ------------------------------------------------------------- + +-- | Abstract types for Javascript expressions in Sunroof. +data Type = Base -- ^ Base type like object or other primtive types. + | Unit -- ^ Unit or void type. There is a effect but no value. + | Fun [Type] Type -- ^ Function type: @(t_1,..,t_n) -> t@ + deriving (Eq,Ord) + +instance Show Type where + show Base = "*" + show Unit = "()" + show (Fun xs t) = show xs ++ " -> " ++ show t + +-- ------------------------------------------------------------- +-- Pretty Printer +-- ------------------------------------------------------------- + +data Doc = Text String -- plain text (assume no newlines) + | Indent Int Doc -- indent document by n + | Sep [Doc] -- on seperate lines + +text :: String -> Doc +text = Text + +--indent :: Int -> Doc -> Doc +--indent = Indent + +sep :: [Doc] -> Doc +sep = Sep + +pretty :: Doc -> String +pretty (Text txt) = txt +pretty (Sep docs) = unlines $ map pretty docs +pretty (Indent n doc) = unlines $ map (take n (cycle " ") ++) $ lines $ pretty doc + + + + diff --git a/Language/Sunroof/Selector.hs b/Language/Sunroof/Selector.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/Selector.hs @@ -0,0 +1,70 @@ + +{-# LANGUAGE ScopedTypeVariables #-} + +-- | 'JSSelector' are used to access fields of Javascript objects. +module Language.Sunroof.Selector + ( JSSelector + , label, index + , unboxSelector + , (!) + ) where + +import Data.String ( IsString(..) ) +import Data.Proxy ( Proxy(Proxy) ) + +import Language.Sunroof.JavaScript ( Expr, E(Dot), ExprE(ExprE) ) +import Language.Sunroof.Classes ( Sunroof(..) ) +import Language.Sunroof.JS.String ( JSString, string ) +import Language.Sunroof.JS.Number ( JSNumber ) + +-- | A 'JSSelector' selects a field or attribute from a Javascript object. +-- The phantom type is the type of the selected value. Note the selected +-- field or attributes may also array entries ('index'). +data JSSelector a = JSSelector Expr + +-- | Selectors can be created from the name of their attribute. +instance IsString (JSSelector a) where + fromString = JSSelector . unbox . string + +instance Show (JSSelector a) where + show (JSSelector ids) = show ids + +-- | Create a selector for a named field or attribute. +-- For type safty it is adivsed to use this with an +-- accompanying type signature. Example: +-- +-- > array ! label "length" +-- +-- See '!' for further information on usage. +label :: JSString -> JSSelector a +label = JSSelector . unbox + +-- | Create a selector for an indexed value (e.g. array access). +-- For type safty it is adivsed to use this with an +-- accompanying type signature. Example: +-- +-- > array ! index 4 +-- +-- See '!' for further information on usage. +index :: JSNumber -> JSSelector a +index = JSSelector . unbox + +-- | Provided for internal usage by the compiler. Unwraps the +-- selector. +unboxSelector :: JSSelector a -> Expr +unboxSelector (JSSelector e) = e + +--------------------------------------------------------------- + +infixl 1 ! + +-- | Operator to use a selector on a Javascript object. Examples: +-- +-- > array ! label "length" +-- > array ! index 4 +(!) :: forall o a . (Sunroof o, Sunroof a) => o -> JSSelector a -> a +(!) arr (JSSelector idx) = box $ Dot (ExprE $ unbox arr) + (ExprE $ idx) + (typeOf (Proxy :: Proxy a)) + + diff --git a/Language/Sunroof/TH.hs b/Language/Sunroof/TH.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/TH.hs @@ -0,0 +1,154 @@ + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +-- | Provides template Haskell code to generate instances for JavaScript +-- object wrappers (). +module Language.Sunroof.TH + ( deriveJSTuple + ) where + +import Language.Haskell.TH +import Language.Sunroof.Types as SRT +import Language.Sunroof.Classes +import Language.Sunroof.JS.Object +import Language.Sunroof.JS.Bool +import Data.Boolean + +-- | @derive@ derives an incomplete instance for @JSTuple@, +-- as well as completing other classes. +-- +-- you write the newtype explictly, and @derive@ does the rest. +-- +-- > newtype JSX o = JSX JSObject +-- +-- and then the start of the JSTuple instance, and the rest gets filled in +-- +-- > derive [d| instance (SunroofArgument o) => JSTuple (JSX o) where +-- > type Internals (JSX o) = (JSString,JSNumber) +-- > |] +-- +-- generates +-- +-- > instance (SunroofArgument o) => Show (JSX o) where +-- > show (JSX o) = show o +-- > +-- > instance (SunroofArgument o) => Sunroof (JSX o) where +-- > unbox (JSX o) = unbox o +-- > box o = JSX (box o) +-- > +-- > instance (SunroofArgument o) => IfB (JSX o) where +-- > ifB = jsIfB +-- > +-- > type instance BooleanOf (JSX o) = JSBool +-- > +-- > instance (SunroofArgument o) => JSTuple (JSX o) where +-- > type instance Internals (JSX o) = (JSString, JSNumber) +-- > match o = (o ! attr "f1", o ! attr "f2") +-- > tuple (v1,v2) = do +-- > o <- new "Object" () +-- > o # attr "f1" := v1 +-- > o # attr "f2" := v2 +-- > return (JSX o) +deriveJSTuple :: Q [Dec] -> Q [Dec] +deriveJSTuple decsQ = do + decs <- decsQ + fmap concat $ mapM complete decs + where + complete :: Dec -> Q [Dec] + complete (InstanceD cxt' (AppT (ConT typeClass) ty) decls) = do + -- Unused: let k decls' = InstanceD cxt' hd (decls ++ decls') + let findClass (ConT t) = t + findClass (AppT t1 _) = findClass t1 + findClass _ = error $ "strange instance head found in derive " ++ show ty + let tConTy = findClass ty + -- Next, find the type instance + let internalTy = case decls of + [TySynInstD tyFun [_arg] internalTy] | tyFun == ''Internals -> internalTy + _ -> error $ "can not find usable type instance inside JSTuple" + let findInternalStructure (TupleT _n) ts = do + vs <- sequence [ newName "v" | _ <- ts ] + return (TupE,TupP [ VarP v | v <- vs], vs `zip` [ "f" ++ show i | (i::Int) <- [1..]]) + findInternalStructure (AppT t1 t2) ts = findInternalStructure t1 (t2 : ts) + findInternalStructure (ConT v) ts = do + info <- reify v + + case info of + TyConI (DataD [] _ _ [NormalC internalCons args] []) -> do + vs <- sequence [ newName "v" | _ <- args ] + return ( foldl AppE (ConE internalCons) + , ConP internalCons [ VarP v | v <- vs] + , vs `zip` [ "f" ++ show i | (i::Int) <- [1..]] + ) + TyConI (NewtypeD [] _ _ (NormalC internalCons args) []) -> do + vs <- sequence [ newName "v" | _ <- args ] + return ( foldl AppE (ConE internalCons) + , ConP internalCons [ VarP v | v <- vs] + , vs `zip` [ "f" ++ show i | (i::Int) <- [1..]] + ) + TyConI (DataD [] _ _ [RecC internalCons args] []) -> do + vs <- sequence [ newName "v" | _ <- args ] + return ( foldl AppE (ConE internalCons) + , ConP internalCons [ VarP v | v <- vs] + , vs `zip` [ nameBase x | (x,_,_) <- args ] + ) + + _o -> error $ "can not find internal structure of cons " ++ show (v,ts,info) + findInternalStructure o ts = error $ "can not find internal structure of type " ++ show (o,ts) + + (builder :: [Exp] -> Exp,unbuilder :: Pat, vars :: [(Name,String)]) <- findInternalStructure internalTy [] + + -- Now work with the tConTy, to get the tCons + info <- reify tConTy + let tCons = case info of + TyConI (NewtypeD _ _ _ (NormalC tCons [(NotStrict,ConT o)]) []) + | o /= ''JSObject -> error $ "not newtype of JSObject" + | typeClass /= ''JSTuple -> error $ "not instance of JSTuple" ++ show (tConTy,''JSTuple) + | otherwise -> tCons + _ -> error $ "strange info for newtype type " ++ show info + + o <- newName "o" + n <- newName "n" + + return [ InstanceD cxt' (AppT (ConT ''Show) ty) + [ FunD 'show + [ Clause [ConP tCons [VarP o]] + (NormalB (AppE (VarE 'show) (VarE o))) []]] + , InstanceD cxt' (AppT (ConT ''Sunroof) ty) + [ FunD 'box + [ Clause [VarP n] (NormalB (AppE (ConE tCons) + (AppE (VarE 'box) (VarE n)))) []] + , FunD 'unbox + [ Clause [ConP tCons [VarP o]] + (NormalB (AppE (VarE 'unbox) (VarE o))) []] + ] + , InstanceD cxt' (AppT (ConT ''IfB) ty) + [ ValD (VarP 'ifB) (NormalB (VarE 'jsIfB)) [] ] + , TySynInstD ''BooleanOf [ty] (ConT ''JSBool) + , InstanceD cxt' (AppT (ConT ''JSTuple) ty) $ decls ++ + [ FunD 'SRT.match + [Clause [VarP o] (NormalB (builder + [ AppE (AppE (VarE $ mkName "!") (VarE o)) + (AppE (VarE 'attr) (LitE $ StringL $ s)) + | (_,s) <- vars ])) []] + , FunD 'SRT.tuple + [ Clause [unbuilder] (NormalB (DoE ( + [ BindS (VarP o) (AppE (AppE (VarE 'new) (LitE $ StringL $ "Object")) (TupE [])) + ] ++ + [ NoBindS $ + let assign = AppE (AppE (ConE $ mkName ":=") + (AppE (VarE 'attr) (LitE $ StringL $ s))) + (VarE v) + + in AppE (AppE (VarE $ mkName "#") + (VarE o)) + (assign) + | (v,s) <- vars + ] ++ + [ NoBindS $ AppE (VarE 'return) (AppE (ConE tCons) (VarE o)) + ]))) [] + ] + ] + ] + complete _ = error "need instance declaration for derivation of JSTuple." diff --git a/Language/Sunroof/Types.hs b/Language/Sunroof/Types.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/Types.hs @@ -0,0 +1,486 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverlappingInstances #-} + +-- | The basic types and combinators of Sunroof. +module Language.Sunroof.Types + ( T(..) + , ThreadProxy(..) + , SunroofThread(..) + , JS(..), JSA, JSB + , unJS + , single + , JSI(..) + , callcc + , done, liftJS, kast + , JSFunction, JSContinuation + , function , continuation, goto + , apply, ($$) + , cast + , (#) + , attr + , fun, invoke, new + , evaluate, value + , switch + , nullJS + , delete + , JSTuple(..) -- TODO: Call this SunroofTuple? + , SunroofKey(..) + ) where + +import Control.Monad.Operational + +import Data.Monoid ( Monoid(..) ) +--import Data.Semigroup ( Semigroup(..) ) +import Data.Boolean ( BooleanOf, IfB(..), EqB(..) ) +import Data.Proxy ( Proxy(Proxy) ) +import Data.Semigroup ( Semigroup(..) ) + +import Language.Sunroof.JavaScript + ( Expr, Type(Fun), Id + , showExpr, literal ) +import Language.Sunroof.Classes + ( Sunroof(..), SunroofValue(..), SunroofArgument(..) ) +import Language.Sunroof.Selector ( JSSelector, label, (!) ) +import Language.Sunroof.JS.Bool ( JSBool, jsIfB ) +import Language.Sunroof.JS.Object ( JSObject, object ) +import Language.Sunroof.JS.Number ( JSNumber ) +import Language.Sunroof.JS.String ( string, JSString ) + +-- ------------------------------------------------------------- +-- Thread Model +-- ------------------------------------------------------------- + +-- | The possible threading models for Javascript computations. +data T = A -- ^ Atomic - The computation will not be interrupted. + | B -- ^ Blocking - The computation may block and wait to enable + -- interleaving with other computations. + deriving (Eq, Ord, Show) + +-- | A proxy to capture the type of threading model used. +-- See 'SunroofThread'. +data ThreadProxy (t :: T) = ThreadProxy + +-- | When implemented the type supports determining the threading model +-- during runtime. +class SunroofThread (t :: T) where + -- | Determine the used threading model captured the given 'ThreadProxy' + -- object. + evalStyle :: ThreadProxy t -> T + -- | Create a possibly blocking computation from the given one. + blockableJS :: (Sunroof a) => JS t a -> JS B a + +instance SunroofThread A where + evalStyle _ = A + blockableJS = liftJS + +instance SunroofThread B where + evalStyle _ = B + blockableJS = id + +-- ------------------------------------------------------------- +-- JS Monad - The Javascript Monad +-- ------------------------------------------------------------- + +infix 5 := + +-- | The monadic type of Javascript computations. +-- +-- @JS t a@ is a computation using the thread model @t@ (see 'T'). +-- It returns a result of type @a@. +data JS :: T -> * -> * where + JS :: ((a -> Program (JSI t) ()) -> Program (JSI t) ()) -> JS t a + (:=) :: (Sunroof a, Sunroof o) => JSSelector a -> a -> o -> JS t () + +-- | Short-hand type for atmoic Javascript computations. +type JSA a = JS A a + +-- | Short-hand type for possibly blocking Javascript computations. +type JSB a = JS B a + +-- | Lifts a single primitive Javascript instruction ('JSI') into the +-- 'JS' monad. +single :: JSI t a -> JS t a +single i = JS $ \ k -> singleton i >>= k + +-- | Unwraps the 'JS' monad into a continuation +-- on 'Control.Monad.Operational.Program'. +unJS :: JS t a -> (a -> Program (JSI t) ()) -> Program (JSI t) () +unJS (JS m) k = m k +unJS ((:=) sel a obj) k = singleton (JS_Assign sel a (cast obj)) >>= k + +instance Monad (JS t) where + return a = JS $ \ k -> return a >>= k + m >>= k = JS $ \ k0 -> unJS m (\ r -> unJS (k r) k0) + +instance Functor (JS t) where + fmap f jsm = jsm >>= (return . f) + +type instance BooleanOf (JS t a) = JSBool + +instance (SunroofThread t, Sunroof a, SunroofArgument a) => IfB (JS t a) where + ifB i h e = single $ JS_Branch i h e + +-- | We define the Semigroup instance for JS, where +-- the first result (but not the first effect) is discarded. +-- Thus, '<>' is the analog of the monadic '>>'. +instance Semigroup (JS t a) where + js1 <> js2 = js1 >> js2 + +instance Monoid (JS t ()) where + mempty = return () + mappend = (<>) + +-- | 'JSI' represents the primitive effects or instructions for +-- the JS monad. +-- +-- [@JS_Assign s v o@] assigns a value @v@ to the selected field @s@ +-- in the object @o@. +-- +-- [@JS_Select s o@] returns the value of the selected field @s@ +-- in the object @o@. +-- +-- [@JS_Delete s o@] delete the selected field @s@ in the object @o@. +-- +-- [@JS_Invoke a f@] calls the function @f@ with the arguments @a@. +-- +-- [@JS_Eval v@] evaluates the value @v@. Subsequent instructions +-- use the value instead of reevaluating the expression. +-- +-- [@JS_Function f@] creates a Javascript function +-- from the Haskell function @f@. +-- +-- [@JS_Continuation f@] creates a Javascript continuation (function that never returns a value) +-- from the Haskell function @f@. +-- +-- [@JS_Branch b t f@] creates a @if-then-else@ statement in Javascript. +-- In that statement @b@ is the condition, @t@ is the true branch and +-- @f@ is the false branch. +-- +-- [@JS_Return v@] translates into an actual @return@ statement that +-- returns the value @v@ in Javascript. +-- +-- [@JS_Assign_ v x@] assigns the value @x@ to the variable with name @v@. +-- +-- [@JS_Fix v x@] models a fixpoint computation in 'JS'. See 'jsfix'. +-- +data JSI :: T -> * -> * where + JS_Assign :: (Sunroof a) => JSSelector a -> a -> JSObject -> JSI t () + JS_Select :: (Sunroof a) => JSSelector a -> JSObject -> JSI t a + JS_Delete :: (Sunroof a) => JSSelector a -> JSObject -> JSI t () + -- Perhaps take the overloaded vs [Expr] and use jsArgs in the compiler? + JS_Invoke :: (SunroofArgument a, Sunroof r) => a -> JSFunction a r -> JSI t r + JS_Eval :: (Sunroof a) => a -> JSI t a + JS_Function :: (SunroofArgument a, Sunroof b) => (a -> JS A b) -> JSI t (JSFunction a b) + JS_Continuation :: (SunroofArgument a) => (a -> JS B ()) -> JSI t (JSContinuation a) + -- Needs? Boolean bool, bool ~ BooleanOf (JS a) + JS_Branch :: (SunroofThread t, Sunroof a, SunroofArgument a, Sunroof bool) => bool -> JS t a -> JS t a -> JSI t a + JS_Return :: (Sunroof a) => a -> JSI t () + JS_Assign_ :: (Sunroof a) => Id -> a -> JSI t () + JS_Comment :: String -> JSI t () + JS_Fix :: (SunroofArgument a) => (a -> JS A a) -> JSI t a + -- TODO: generalize Assign[_] to have a RHS + +-- ------------------------------------------------------------- +-- Cross the Threading Model Combinators +-- ------------------------------------------------------------- + +-- | Lift the atomic computation into another computation. +liftJS :: (Sunroof a) => JS A a -> JS t a +liftJS m = do + o <- function (\ () -> m) + apply o () + +-- ------------------------------------------------------------- +-- JSFunction Type +-- ------------------------------------------------------------- + +-- | Type of Javascript functions. +-- The first type argument is the type of function argument. +-- This needs to be a instance of 'SunroofArgument'. +-- The second type argument of 'JSFunction' is the function return type. +-- It needs to be a instance of 'Sunroof'. +data JSFunction args ret = JSFunction Expr + +instance Show (JSFunction a r) where + show (JSFunction v) = showExpr False v + +-- | Functions are first-class citizens of Javascript. Therefore they +-- are 'Sunroof' values. +instance forall a r . (SunroofArgument a, Sunroof r) => Sunroof (JSFunction a r) where + box = JSFunction + unbox (JSFunction e) = e + typeOf _ = Fun (typesOf (Proxy :: Proxy a)) (typeOf (Proxy :: Proxy r)) + +type instance BooleanOf (JSFunction a r) = JSBool + +-- | Functions may be the result of a branch. +instance (SunroofArgument a, Sunroof r) => IfB (JSFunction a r) where + ifB = jsIfB + +-- | 'JSFunction's may be created from Haskell functions if they have +-- the right form. +instance (SunroofArgument a, Sunroof b) => SunroofValue (a -> JS A b) where + type ValueOf (a -> JS A b) = JS A (JSFunction a b) -- TO revisit + js = function + +-- ------------------------------------------------------------- +-- JSFunction Combinators +-- ------------------------------------------------------------- + +-- | Create a binding to a Javascript top-level function with +-- the given name. It is advised to create these bindings with an +-- associated type signature to ensure type safty while using +-- this function. Example: +-- +-- > alert :: JSFunction JSString () +-- > alert = fun "alert" +fun :: (SunroofArgument a, Sunroof r) => String -> JSFunction a r +fun = JSFunction . literal + +-- | Create an 'A'tomic Javascript function from a Haskell function. +function :: (SunroofArgument a, Sunroof b) => (a -> JS A b) -> JS t (JSFunction a b) +function = single . JS_Function + +infixl 1 `apply` + +-- | @apply f a@ applies the function @f@ to the given arguments @a@. +-- A typical use case looks like this: +-- +-- > foo `apply` (x,y) +-- +-- See '$$' for a convenient infix operator to do this. +apply :: (SunroofArgument args, Sunroof ret) => JSFunction args ret -> args -> JS t ret +apply f args = f # with args + where + with :: (SunroofArgument a, Sunroof r) => a -> JSFunction a r -> JS t r + with a fn = single $ JS_Invoke a fn + +-- | @f $$ a@ applies the function 'f' to the given arguments @a@. +-- See 'apply'. +($$) :: (SunroofArgument args, Sunroof ret) => JSFunction args ret -> args -> JS t ret +($$) = apply + +-- ------------------------------------------------------------- +-- JSContinuation Type +-- ------------------------------------------------------------- + +-- | Type of Javascript functions. +-- The first type argument is the type of function argument. +-- This needs to be a instance of 'SunroofArgument'. +-- The second type argument of 'JSFunction' is the function return type. +-- It needs to be a instance of 'Sunroof'. +data JSContinuation args = JSContinuation Expr + +instance Show (JSContinuation a) where + show (JSContinuation v) = showExpr False v + +-- | Functions are first-class citizens of Javascript. Therefore they +-- are 'Sunroof' values. +instance forall a . (SunroofArgument a) => Sunroof (JSContinuation a) where + box = JSContinuation + unbox (JSContinuation e) = e + typeOf _ = Fun (typesOf (Proxy :: Proxy a)) (typeOf (Proxy :: Proxy ())) + +type instance BooleanOf (JSContinuation a) = JSBool + +-- | Functions may be the result of a branch. +instance (SunroofArgument a, Sunroof r) => IfB (JSContinuation a) where + ifB = jsIfB + +-- | 'JSFunction's may be created from Haskell functions if they have +-- the right form. +instance (SunroofArgument a) => SunroofValue (a -> JS B ()) where + type ValueOf (a -> JS B ()) = JS B (JSContinuation a) -- TO revisit + js = continuation + +-- ------------------------------------------------------------- +-- JSFunction Combinators +-- ------------------------------------------------------------- + +-- | We can compile 'B'lockable functions that return @()@. +-- Note that, with the 'B'-style threads, we return from a +-- call when we first block, not at completion of the call. +continuation :: (SunroofArgument a) => (a -> JS B ()) -> JS t (JSContinuation a) +continuation = single . JS_Continuation + +-- | @kast@ is cast to continuation. @k@ is the letter often used to signify a continuation. +kast :: (SunroofArgument a) => JSFunction a () -> JSContinuation a +kast = cast + +-- Implementation of goto and callCC from +-- http://stackoverflow.com/questions/9050725/call-cc-implementation +-- +-- | Reify the current contination as a Javascript continuation +callcc :: SunroofArgument a => (JSContinuation a -> JS B a) -> JS B a +callcc f = JS $ \ cc -> unJS (do o <- continuation (goto' cc) + f o + ) cc + where goto' :: (x ~ ()) => (a -> Program (JSI B) ()) -> a -> JS B x + goto' cont argument = JS $ \ _ -> cont argument + + +-- | Abort the current computation at this point. +done :: JS t a +done = JS $ \ _ -> return () + +-- | @goto@ calls the given continuation with the given argument, +-- and never returns. +goto :: forall args a t . (SunroofArgument args) => JSContinuation args -> args -> JS t a +goto k args = JS $ \ _ -> singleton $ JS_Invoke args (cast k :: JSFunction args ()) + +-- ------------------------------------------------------------- +-- Basic Combinators +-- ------------------------------------------------------------- + +-- | Cast one Sunroof value into another. +-- +-- This is sometimes needed due to Javascripts flexible type system. +cast :: (Sunroof a, Sunroof b) => a -> b +cast = box . unbox + +infixr 0 # + +-- | The @#@-operator is the Haskell analog to the @.@-operator +-- in Javascript. Example: +-- +-- > document # getElementById "bla" +-- +-- This can be seen as equivalent of @document.getElementById(\"bla\")@. +(#) :: a -> (a -> JS t b) -> JS t b +(#) obj act = act obj +-- We should use this operator for the obj.label concept. +-- It has been used in other places (but I can not seems +-- to find a library for it) + +-- | Creates a selector for attributes of Javascript objects. +-- It is advised to use this together with an associated type +-- signature to avoid ambiguity. Example: +-- +-- > length :: JSSelector JSNumber +-- > length = attr "length" +-- +-- Selectors can be used with '!'. +attr :: String -> JSSelector a +attr a = label $ string a + +-- | @invoke s a o@ calls the method with name @s@ using the arguments @a@ +-- on the object @o@. A typical use would look like this: +-- +-- > o # invoke "foo" (x, y) +-- +-- Another use case is writing Javascript API bindings for common methods: +-- +-- > getElementById :: JSString -> JSObject -> JS t JSObject +-- > getElementById s = invoke "getElementById" s +-- +-- Like this the flexible type signature gets fixed. See 'Language.Sunroof.Types.#' +-- for how to use these bindings. +invoke :: (SunroofArgument a, Sunroof r, Sunroof o) => String -> a -> o -> JS t r +invoke str args obj = (obj ! attr str) `apply` args + +-- | @new n a@ calls the new operator on the constructor @n@ +-- supplying the argument @a@. A typical use would look like this: +-- +-- > new "Object" () +-- +new :: (SunroofArgument a) => String -> a -> JS t JSObject +new cons args = fun ("new " ++ cons) `apply` args + +-- | Evaluate a 'Sunroof' value. This forces evaluation +-- of the given expression to a value and enables binding it to a +-- variable. Example: +-- +-- > x <- evaluate $ "A" <> "B" +-- > alert x +-- > alert x +-- +-- This would result in: @var v0 = \"A\"+\"B\"; alert(v0); alert(v0);@. But: +-- +-- > x <- return $ "A" <> "B" +-- > alert x +-- > alert x +-- +-- This will result in: @alert(\"A\"+\"B\"); alert(\"A\"+\"B\");@. +evaluate :: (Sunroof a) => a -> JS t a +evaluate a = single (JS_Eval a) + +-- | Synonym for 'evaluate'. +value :: (Sunroof a) => a -> JS t a +value = evaluate + +-- | Combinator for @switch@-like statements in Javascript. +-- +-- /Note/: This will not be translated into +-- actual switch statment, because you are aloud arbitrary +-- expressions in the cases. +switch :: ( EqB a, BooleanOf a ~ JSBool + , Sunroof a, Sunroof b + , SunroofArgument b + , SunroofThread t + ) => a -> [(a,JS t b)] -> JS t b +switch _a [] = return (cast (object "undefined")) +switch a ((c,t):e) = ifB (a ==* c) t (switch a e) + +-- | The @null@ reference in Javascript. +nullJS :: JSObject +nullJS = box $ literal "null" + +-- ------------------------------------------------------------- +-- delete +-- ------------------------------------------------------------- + +-- | @o # delete lab@ removes the label @lab@ from the object @o@. +delete :: (Sunroof a) => JSSelector a -> JSObject -> JS t () +delete sel o = single (JS_Delete sel o) + +-- ------------------------------------------------------------- +-- JSTuple Type Class +-- ------------------------------------------------------------- + +-- | If something is a 'JSTuple', it can easily be decomposed and +-- recomposed from different components. This is meant as a convenient +-- access to attributes of an object. +-- TODO: revisit this +class Sunroof o => JSTuple o where + type Internals o + match :: (Sunroof o) => o -> Internals o + tuple :: Internals o -> JS t o + +instance JSTuple JSObject where + type Internals JSObject = () + match _ = () + tuple () = new "Object" () + + +-- ------------------------------------------------------------- +-- SunroofKey Type Class +-- ------------------------------------------------------------- + +-- | Everything that can be used as an key in a dictionary lookup. +class Sunroof key => SunroofKey key where + jsKey :: key -> JSSelector a + +-- To break the module loop +instance SunroofKey JSString where + jsKey = label + +instance SunroofKey JSNumber where + jsKey k = label ("" <> cast k) + +instance SunroofKey JSBool where + jsKey k = label ("" <> cast k) + + + + + diff --git a/Language/Sunroof/Utils.hs b/Language/Sunroof/Utils.hs new file mode 100644 --- /dev/null +++ b/Language/Sunroof/Utils.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +-- | Common utilities for Sunroof. +module Language.Sunroof.Utils + ( comment, fixJS + ) where + +import Language.Sunroof.Classes +import Language.Sunroof.Types + +-- ------------------------------------------------------------- +-- Comments +-- ------------------------------------------------------------- + +-- | Write a JavaScript comment into the generated source. +comment :: String -> JS t () +comment = single . JS_Comment + +-- ------------------------------------------------------------- +-- Fixpoint combinator +-- ------------------------------------------------------------- + +-- | @jsfix@ is the @mfix@ for the JS Monad. +fixJS :: (SunroofArgument a) => (a -> JSA a) -> JS t a +fixJS = single . JS_Fix diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,46 @@ +Sunroof +======= + +Sunroof is a Haskell-hosted Domain Specific Language (DSL) for generating JavaScript. +Sunroof is build on top of the `JS`-monad, which, like the Haskell `IO`-monad, allows +access to external resources, but specifically JavaScript +resources. As such, Sunroof is primarily a feature-rich foreign +function API to the browser's JavaScript engine, and all the browser-specific +functionality, including HTML-based rendering, event handling, and +drawing to the HTML5 canvas. + +It uses monadic reification, to reify a deep embedding of the `JS`-monad, +and from this embedding it generates JavaScript. +The Sunroof DSL has the feel of native Haskell, with a simple +Haskell-based type schema to guide the Sunroof programmer. +Furthermore, because it generates code, +Sunroof can offer Haskell-style concurrency patterns, like `MVar`s and `Chan`nels. +In combination with a web services package like [`kansas-comet`][HackageKansasComet], +the Sunroof compiler offers a robust platform to build interactive web applications, +giving the ability to interleave Haskell and JavaScript computations +with each other as needed ([`sunroof-server`][HackageSunroofServer]). + +Further Information +------------------- + +Further information on Sunroof can be found in different places: + + * [Project Homepage](http://www.ittc.ku.edu/csdl/fpg/software/sunroof.html) + * [Tutorial](https://github.com/ku-fpg/sunroof-compiler/wiki/Tutorial) + * [Examples](https://github.com/ku-fpg/sunroof-compiler/wiki/Examples) + * [Project Wiki & Development Resources](https://github.com/ku-fpg/sunroof-compiler/wiki) + * Hackage + + [sunroof-compiler](http://hackage.haskell.org/package/sunroof-compiler) + + [sunroof-server][HackageSunroofServer] + + [sunroof-examples](http://hackage.haskell.org/package/sunroof-examples) + * Github + + [sunroof-compiler](https://github.com/ku-fpg/sunroof-compiler) + + [sunroof-server](https://github.com/ku-fpg/sunroof-server) + + [sunroof-examples](https://github.com/ku-fpg/sunroof-examples) + + + + +[HackageKansasComet]: http://hackage.haskell.org/package/kansas-comet +[HackageSunroofServer]: http://hackage.haskell.org/package/sunroor-server + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/sunroof-compiler.cabal b/sunroof-compiler.cabal new file mode 100644 --- /dev/null +++ b/sunroof-compiler.cabal @@ -0,0 +1,65 @@ +Name: sunroof-compiler +Version: 0.2 +Synopsis: Monadic Javascript Compiler +Homepage: https://github.com/ku-fpg/sunroof-compiler +Bug-reports: https://github.com/ku-fpg/sunroof-compiler +License: BSD3 +License-file: LICENSE +Author: Andrew Gill , Jan Bracker +Maintainer: Jan Bracker +Copyright: (c) 2012 The University of Kansas +Category: Web, Language, Embedded, Compiler, Javascript +Stability: experimental +Build-type: Simple +Cabal-version: >= 1.10 +Description: + Monadic Javascript Compiler. + +Extra-source-files: + README.md + +Library + Exposed-modules: Language.Sunroof + Language.Sunroof.Types + Language.Sunroof.Classes + Language.Sunroof.JavaScript + Language.Sunroof.Compiler + Language.Sunroof.Concurrent + Language.Sunroof.Internal + Language.Sunroof.Selector + Language.Sunroof.TH + Language.Sunroof.Utils + Language.Sunroof.JS.Ref + Language.Sunroof.JS.Bool + Language.Sunroof.JS.Object + Language.Sunroof.JS.String + Language.Sunroof.JS.Number + Language.Sunroof.JS.Array + Language.Sunroof.JS.Date + Language.Sunroof.JS.Chan + Language.Sunroof.JS.MVar + Language.Sunroof.JS.Canvas + Language.Sunroof.JS.Browser + Language.Sunroof.JS.JQuery + Language.Sunroof.JS.Map + + default-language: Haskell2010 + build-depends: data-reify >= 0.6, + base >= 4.3.1 && < 5, + Boolean >= 0.2, + containers >= 0.4, + data-default == 0.5.*, + vector-space >= 0.8.6, + mtl >= 2.0, + template-haskell >= 2.8, + operational >= 0.2.0.3 && < 0.3, + semigroups >= 0.9, + transformers == 0.3.*, + tagged >= 0.4.4 + + + GHC-options: -Wall -fno-warn-orphans + +source-repository head + type: git + location: git://github.com/ku-fpg/sunroof-compiler.git