sunroof-compiler (empty) → 0.2
raw patch · 27 files changed
+4251/−0 lines, 27 filesdep +Booleandep +basedep +containerssetup-changed
Dependencies added: Boolean, base, containers, data-default, data-reify, mtl, operational, semigroups, tagged, template-haskell, transformers, vector-space
Files
- LICENSE +30/−0
- Language/Sunroof.hs +202/−0
- Language/Sunroof/Classes.hs +220/−0
- Language/Sunroof/Compiler.hs +422/−0
- Language/Sunroof/Concurrent.hs +73/−0
- Language/Sunroof/Internal.hs +19/−0
- Language/Sunroof/JS/Array.hs +116/−0
- Language/Sunroof/JS/Bool.hs +63/−0
- Language/Sunroof/JS/Browser.hs +349/−0
- Language/Sunroof/JS/Canvas.hs +480/−0
- Language/Sunroof/JS/Chan.hs +90/−0
- Language/Sunroof/JS/Date.hs +294/−0
- Language/Sunroof/JS/JQuery.hs +173/−0
- Language/Sunroof/JS/MVar.hs +120/−0
- Language/Sunroof/JS/Map.hs +73/−0
- Language/Sunroof/JS/Number.hs +158/−0
- Language/Sunroof/JS/Object.hs +52/−0
- Language/Sunroof/JS/Ref.hs +69/−0
- Language/Sunroof/JS/String.hs +119/−0
- Language/Sunroof/JavaScript.hs +280/−0
- Language/Sunroof/Selector.hs +70/−0
- Language/Sunroof/TH.hs +154/−0
- Language/Sunroof/Types.hs +486/−0
- Language/Sunroof/Utils.hs +26/−0
- README.md +46/−0
- Setup.hs +2/−0
- sunroof-compiler.cabal +65/−0
+ LICENSE view
@@ -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.
+ Language/Sunroof.hs view
@@ -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 )
+ Language/Sunroof/Classes.hs view
@@ -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)+ ]++++++
+ Language/Sunroof/Compiler.hs view
@@ -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
+ Language/Sunroof/Concurrent.hs view
@@ -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+++++++++++++
+ Language/Sunroof/Internal.hs view
@@ -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 ++ ")"
+ Language/Sunroof/JS/Array.hs view
@@ -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 <http://www.w3schools.com/jsref/jsref_push.asp>.+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 <http://www.w3schools.com/jsref/jsref_unshift.asp>.+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 <http://www.w3schools.com/jsref/jsref_pop.asp>.+pop :: (Sunroof a) => JSArray a -> JS t a+pop = invoke "pop" ()++-- | Removes and return the first element of an array (dequeue).+-- See <http://www.w3schools.com/jsref/jsref_shift.asp>.+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+-- <https://developer.mozilla.org/en-US/docs/JavaScript/Reference/Global_Objects/Array/forEach>,+-- <http://msdn.microsoft.com/en-us/library/ie/ff679980.aspx>.+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 ()
+ Language/Sunroof/JS/Bool.hs view
@@ -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]
+ Language/Sunroof/JS/Browser.hs view
@@ -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 <http://www.w3schools.com/js/js_popup.asp>.+alert :: JSString -> JS t ()+alert msg = fun "alert" `apply` (msg)++-- | Ask the user to confirm the given massege.+--+-- See <http://www.w3schools.com/js/js_popup.asp>.+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 <http://www.w3schools.com/js/js_popup.asp>.+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: <http://www.w3schools.com/jsref/met_win_setinterval.asp>+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: <http://www.w3schools.com/jsref/met_win_clearinterval.asp>+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: <http://www.w3schools.com/jsref/met_win_settimeout.asp>+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: <http://www.w3schools.com/jsref/met_win_cleartimeout.asp>+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:+-- <https://developers.google.com/chrome-developer-tools/docs/console-api>,+-- <https://developer.mozilla.org/en-US/docs/DOM/console>,+-- <http://msdn.microsoft.com/en-us/library/windows/apps/hh696634.aspx>;+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++
+ Language/Sunroof/JS/Canvas.hs view
@@ -0,0 +1,480 @@++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++-- | Provides bindings to the Javascript API of the +-- HTML5 canvas element.+-- +-- See <http://www.w3schools.com/tags/ref_canvas.asp>.+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"+
+ Language/Sunroof/JS/Chan.hs view
@@ -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+ )+++
+ Language/Sunroof/JS/Date.hs view
@@ -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 (<http://www.w3schools.com/jsref/jsref_obj_date.asp>).+-- 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: <http://www.w3schools.com/jsref/jsref_obj_date.asp>+newDate :: (SunroofArgument a) => a -> JS t JSDate+newDate args = cast `fmap` new "Date" args++-- | Returns the hour (from 0-23).+-- See: <http://www.w3schools.com/jsref/jsref_gethours.asp>+getHours :: JSDate -> JS t JSNumber+getHours = invoke "getHours" ()++-- | Returns the minutes (from 0-59).+-- See: <http://www.w3schools.com/jsref/jsref_getminutes.asp>+getMinutes :: JSDate -> JS t JSNumber+getMinutes = invoke "getMinutes" ()++-- | Returns the seconds (from 0-59).+-- See: <http://www.w3schools.com/jsref/jsref_getseconds.asp>+getSeconds :: JSDate -> JS t JSNumber+getSeconds = invoke "getSeconds" ()++-- | Returns the day of the month (from 1-31).+-- See: <http://www.w3schools.com/jsref/jsref_getdate.asp>+getDate :: JSDate -> JS t JSNumber+getDate = invoke "getDate" ()++-- | Returns the day of the week (from 0-6).+-- See: <http://www.w3schools.com/jsref/jsref_getday.asp>+getDay :: JSDate -> JS t JSNumber+getDay = invoke "getDay" ()++-- | Returns the year (four digits).+-- See: <http://www.w3schools.com/jsref/jsref_getfullyear.asp>+getFullYear :: JSDate -> JS t JSNumber+getFullYear = invoke "getFullYear" ()++-- | Returns the milliseconds (from 0-999).+-- See: <http://www.w3schools.com/jsref/jsref_getmilliseconds.asp>+getMilliseconds :: JSDate -> JS t JSNumber+getMilliseconds = invoke "getMilliseconds" ()++-- | Returns the month (from 0-11).+-- See: <http://www.w3schools.com/jsref/jsref_getmonth.asp>+getMonth :: JSDate -> JS t JSNumber+getMonth = invoke "getMonth" ()++-- | Returns the number of milliseconds since midnight Jan 1, 1970.+-- See: <http://www.w3schools.com/jsref/jsref_gettime.asp>+getTime :: JSDate -> JS t JSNumber+getTime = invoke "getTime" ()++-- | Returns the time difference between UTC time and local time, in minutes.+-- See: <http://www.w3schools.com/jsref/jsref_gettimezoneoffset.asp>+getTimezoneOffset :: JSDate -> JS t JSNumber+getTimezoneOffset = invoke "getTimezoneOffset" ()++-- | Returns the day of the month, according to universal time (from 1-31).+-- See: <http://www.w3schools.com/jsref/jsref_getutcdate.asp>+getUTCDate :: JSDate -> JS t JSNumber+getUTCDate = invoke "getUTCDate" ()++-- | Returns the day of the week, according to universal time (from 0-6).+-- See: <http://www.w3schools.com/jsref/jsref_getutcday.asp>+getUTCDay :: JSDate -> JS t JSNumber+getUTCDay = invoke "getUTCDay" ()++-- | Returns the year, according to universal time (four digits).+-- See: <http://www.w3schools.com/jsref/jsref_getutcfullyear.asp>+getUTCFullYear :: JSDate -> JS t JSNumber+getUTCFullYear = invoke "getUTCFullYear" ()++-- | Returns the hour, according to universal time (from 0-23).+-- See: <http://www.w3schools.com/jsref/jsref_getutchours.asp>+getUTCHours :: JSDate -> JS t JSNumber+getUTCHours = invoke "getUTCHours" ()++-- | Returns the milliseconds, according to universal time (from 0-999).+-- See: <http://www.w3schools.com/jsref/jsref_getutcmilliseconds.asp>+getUTCMilliseconds :: JSDate -> JS t JSNumber+getUTCMilliseconds = invoke "getUTCMilliseconds" ()++-- | Returns the minutes, according to universal time (from 0-59).+-- See: <http://www.w3schools.com/jsref/jsref_getutcminutes.asp>+getUTCMinutes :: JSDate -> JS t JSNumber+getUTCMinutes = invoke "getUTCMinutes" ()++-- | Returns the month, according to universal time (from 0-11).+-- See: <http://www.w3schools.com/jsref/jsref_getutcmonth.asp>+getUTCMonth :: JSDate -> JS t JSNumber+getUTCMonth = invoke "getUTCMonth" ()++-- | Returns the seconds, according to universal time (from 0-59).+-- See: <http://www.w3schools.com/jsref/jsref_getutcseconds.asp>+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: <http://www.w3schools.com/jsref/jsref_parse.asp>+parseDate :: JSString -> JSDate -> JS t JSNumber+parseDate str = invoke "parse" str++-- | Sets the day of the month of a date object.+-- See: <http://www.w3schools.com/jsref/jsref_setdate.asp>+setDate :: JSNumber -> JSDate -> JS t ()+setDate n = invoke "setDate" n++-- | Sets the year (four digits) of a date object.+-- See: <http://www.w3schools.com/jsref/jsref_setfullyear.asp>+setFullYear :: JSNumber -> JSDate -> JS t ()+setFullYear n = invoke "setFullYear" n++-- | Sets the hour of a date object.+-- See: <http://www.w3schools.com/jsref/jsref_sethours.asp>+setHours :: JSNumber -> JSDate -> JS t ()+setHours n = invoke "setHours" n++-- | Sets the milliseconds of a date object.+-- See: <http://www.w3schools.com/jsref/jsref_setmilliseconds.asp>+setMilliseconds :: JSNumber -> JSDate -> JS t ()+setMilliseconds n = invoke "setMilliseconds" n++-- | Set the minutes of a date object.+-- See: <http://www.w3schools.com/jsref/jsref_setminutes.asp>+setMinutes :: JSNumber -> JSDate -> JS t ()+setMinutes n = invoke "setMinutes" n++-- | Sets the month of a date object.+-- See: <http://www.w3schools.com/jsref/jsref_setmonth.asp>+setMonth :: JSNumber -> JSDate -> JS t ()+setMonth n = invoke "setMonth" n++-- | Sets the seconds of a date object.+-- See: <http://www.w3schools.com/jsref/jsref_setseconds.asp>+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: <http://www.w3schools.com/jsref/jsref_settime.asp>+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: <http://www.w3schools.com/jsref/jsref_setutcdate.asp>+setUTCDate :: JSNumber -> JSDate -> JS t ()+setUTCDate n = invoke "setUTCDate" n++-- | Sets the year of a date object, according to universal time (four digits).+-- See: <http://www.w3schools.com/jsref/jsref_setutcfullyear.asp>+setUTCFullYear :: JSNumber -> JSDate -> JS t ()+setUTCFullYear n = invoke "setUTCFullYear" n++-- | Sets the hour of a date object, according to universal time.+-- See: <http://www.w3schools.com/jsref/jsref_setutchours.asp>+setUTCHours :: JSNumber -> JSDate -> JS t ()+setUTCHours n = invoke "setUTCHours" n++-- | Sets the milliseconds of a date object, according to universal time.+-- See: <http://www.w3schools.com/jsref/jsref_setutcmilliseconds.asp>+setUTCMilliseconds :: JSNumber -> JSDate -> JS t ()+setUTCMilliseconds n = invoke "setUTCMilliseconds" n++-- | Set the minutes of a date object, according to universal time.+-- See: <http://www.w3schools.com/jsref/jsref_setutcminutes.asp>+setUTCMinutes :: JSNumber -> JSDate -> JS t ()+setUTCMinutes n = invoke "setUTCMinutes" n++-- | Sets the month of a date object, according to universal time.+-- See: <http://www.w3schools.com/jsref/jsref_setutcmonth.asp>+setUTCMonth :: JSNumber -> JSDate -> JS t ()+setUTCMonth n = invoke "setUTCMonth" n++-- | Set the seconds of a date object, according to universal time.+-- See: <http://www.w3schools.com/jsref/jsref_setutcseconds.asp>+setUTCSeconds :: JSNumber -> JSDate -> JS t ()+setUTCSeconds n = invoke "setUTCSeconds" n++-- | Converts the date portion of a Date object into a readable string.+-- See: <http://www.w3schools.com/jsref/jsref_todatestring.asp>+toDateString :: JSDate -> JS t JSString+toDateString = invoke "toDateString" ()++-- | Returns the date as a string, using the ISO standard.+-- See: <http://www.w3schools.com/jsref/jsref_toisostring.asp>+toISOString :: JSDate -> JS t JSString+toISOString = invoke "toISOString" ()++-- | Returns the date as a string, formated as a JSON date.+-- See: <http://www.w3schools.com/jsref/jsref_tojson.asp>+toJSON :: JSDate -> JS t JSString+toJSON = invoke "toJSON" ()++-- | Returns the date portion of a Date object as a string, +-- using locale conventions.+-- See: <http://www.w3schools.com/jsref/jsref_tolocaledatestring.asp>+toLocaleDateString :: JSDate -> JS t JSString+toLocaleDateString = invoke "toLocaleDateString" ()++-- | Returns the time portion of a Date object as a string, +-- using locale conventions.+-- See: <http://www.w3schools.com/jsref/jsref_tolocaletimestring.asp>+toLocaleTimeString :: JSDate -> JS t JSString+toLocaleTimeString = invoke "toLocaleTimeString" ()++-- | Converts a Date object to a string, using locale conventions.+-- See: <http://www.w3schools.com/jsref/jsref_tolocalestring.asp>+toLocaleString :: JSDate -> JS t JSString+toLocaleString = invoke "toLocaleString" ()++-- | Converts a Date object to a string.+-- See: <http://www.w3schools.com/jsref/jsref_tostring_date.asp>+toString :: JSDate -> JS t JSString+toString = invoke "toString" ()++-- | Converts the time portion of a Date object to a string.+-- See: <http://www.w3schools.com/jsref/jsref_totimestring.asp>+toTimeString :: JSDate -> JS t JSString+toTimeString = invoke "toTimeString" ()++-- | Converts a Date object to a string, according to universal time.+-- See: <http://www.w3schools.com/jsref/jsref_toutcstring.asp>+toUTCString :: JSDate -> JS t JSString+toUTCString = invoke "toUTCString" ()+
+ Language/Sunroof/JS/JQuery.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE DataKinds #-}++-- | This module provides parts of the JQuery API (<http://api.jquery.com/>).+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 <http://api.jquery.com/jQuery/>.+dollar :: JSFunction JSString JSObject+dollar = fun "$"++-- | Calls the JQuery dollar function.+-- See <http://api.jquery.com/jQuery/>.+jQuery :: JSString -> JS t JSObject+jQuery nm = dollar `apply` nm++-- | Short-hand for 'jQuery'.+jq :: JSString -> JS t JSObject+jq = jQuery++-- -----------------------------------------------------------------------+-- Manipulation > DOM+-- -----------------------------------------------------------------------++-- | See <http://api.jquery.com/append/>.+append :: JSObject -> JSObject -> JS t ()+append x = invoke "append" x++-- | See @.html()@ at <http://api.jquery.com/html/>.+html :: JSObject -> JS t JSObject+html = invoke "html" ()++-- | See @.html(htmlString)@ at <http://api.jquery.com/html/>.+setHtml :: JSString -> JSObject -> JS t JSObject+setHtml s = invoke "html" s++-- | See @.text()@ at <http://api.jquery.com/text/>.+text :: JSObject -> JS t JSObject+text = invoke "text" ()++-- | See @.text(textString)@ at <http://api.jquery.com/text/>.+setText :: JSString -> JSObject -> JS t JSObject+setText s = invoke "text" s++-- -------------------------------------------------------------+-- CSS+-- -------------------------------------------------------------++-- | See @.css(propertyName)@ at <http://api.jquery.com/css/>.+css :: JSString -> JSObject -> JS t JSString+css prop = invoke "css" prop++-- | See @.css(propertyName, value)@ at <http://api.jquery.com/css/>.+setCss :: JSString -> JSString -> JSObject -> JS t JSString+setCss prop v = invoke "css" (prop, v)++-- | See <http://api.jquery.com/addClass/>.+addClass :: JSString -> JSObject -> JS t ()+addClass = invoke "addClass"++-- | See <http://api.jquery.com/removeClass/>.+removeClass :: JSString -> JSObject -> JS t ()+removeClass = invoke "removeClass"++-- -------------------------------------------------------------+-- Attributes+-- -------------------------------------------------------------++-- | See @.attr(attributeName)@ at <http://api.jquery.com/attr/>.+-- 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 <http://api.jquery.com/attr/>.+-- 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 <http://api.jquery.com/attr/>.+setAttr :: JSString -> JSString -> JSObject -> JS t JSString+setAttr a v = invoke "attr" (a, v)++-- | See: <http://api.jquery.com/removeAttr/>+removeAttr :: JSString -> JSObject -> JS t JSObject+removeAttr attrName = invoke "removeAttr" attrName++-- -------------------------------------------------------------+-- Event Handling+-- -------------------------------------------------------------++-- | See <http://api.jquery.com/on/>.+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 <http://api.jquery.com/innerHeight/>.+innerWidth :: JSObject -> JS t JSNumber+innerWidth = invoke "innerWidth" ()++-- | See <http://api.jquery.com/innerWidth/>.+innerHeight :: JSObject -> JS t JSNumber+innerHeight = invoke "innerHeight" ()++-- | See <http://api.jquery.com/outerWidth/>.+outerWidth :: JSObject -> JS t JSNumber+outerWidth = invoke "outerWidth" ()++-- | See <http://api.jquery.com/outerWidth/>.+outerWidth' :: JSBool -> JSObject -> JS t JSNumber+outerWidth' includeMargin = invoke "outerWidth" includeMargin++-- | See <http://api.jquery.com/outerHeight/>.+outerHeight :: JSObject -> JS t JSNumber+outerHeight = invoke "outerHeight" ()++-- | See <http://api.jquery.com/outerHeight/>.+outerHeight' :: JSBool -> JSObject -> JS t JSNumber+outerHeight' includeMargin = invoke "outerHeight" includeMargin++-- | See @.clone()@ at <http://api.jquery.com/clone/>.+clone :: JSObject -> JS t JSObject+clone = invoke "clone" ()++-- | See @.clone(withDataAndEvents, deepWithDataAndEvents)@ at <http://api.jquery.com/clone/>.+clone' :: JSBool -> JSBool -> JSObject -> JS t JSObject+clone' withDataAndEvents deepWithDataAndEvents =+ invoke "clone" (withDataAndEvents, deepWithDataAndEvents)++
+ Language/Sunroof/JS/MVar.hs view
@@ -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+ )++
+ Language/Sunroof/JS/Map.hs view
@@ -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)++
+ Language/Sunroof/JS/Number.hs view
@@ -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++++++++
+ Language/Sunroof/JS/Object.hs view
@@ -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"
+ Language/Sunroof/JS/Ref.hs view
@@ -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
+ Language/Sunroof/JS/String.hs view
@@ -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
+ Language/Sunroof/JavaScript.hs view
@@ -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++++
+ Language/Sunroof/Selector.hs view
@@ -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))++
+ Language/Sunroof/TH.hs view
@@ -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 (<https://github.com/ku-fpg/sunroof-compiler/wiki/JSObject-Wrapper-Types>).+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."
+ Language/Sunroof/Types.hs view
@@ -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)+++++
+ Language/Sunroof/Utils.hs view
@@ -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
+ README.md view
@@ -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+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ sunroof-compiler.cabal view
@@ -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 <andygill@ku.edu>, Jan Bracker <jbra@informatik.uni-kiel.de>+Maintainer: Jan Bracker <jbra@informatik.uni-kiel.de>+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