diff --git a/haste-compiler.cabal b/haste-compiler.cabal --- a/haste-compiler.cabal +++ b/haste-compiler.cabal @@ -1,5 +1,5 @@ Name: haste-compiler -Version: 0.4.2.1 +Version: 0.4.3 License: BSD3 License-File: LICENSE Synopsis: Haskell To ECMAScript compiler @@ -13,7 +13,7 @@ Build-Type: Custom Author: Anton Ekblad Maintainer: anton@ekblad.cc -Homepage: http://github.com/valderman/haste-compiler +Homepage: http://haste-lang.org/ Bug-reports: http://github.com/valderman/haste-compiler/issues Stability: Experimental @@ -190,6 +190,28 @@ directory default-language: Haskell98 +Executable haste-cat + Main-Is: haste-cat.hs + Other-Modules: + Haste.Environment + Hs-Source-Dirs: src + if flag(portable) + CPP-Options: -DPORTABLE + Build-Depends: + base < 5, + shellmate >= 0.1.5, + ghc-paths, + ghc, + binary, + containers, + blaze-builder, + bytestring, + array, + random, + data-default, + directory + default-language: Haskell98 + Library Hs-Source-Dirs: libraries/haste-lib/src, src GHC-Options: -Wall -O2 @@ -254,5 +276,7 @@ network-uri < 2.6 else Build-Depends: - websockets >= 0.8 + websockets >= 0.8, + network >= 2.6, + network-uri >= 2.6 Default-Language: Haskell98 diff --git a/lib/rts.js b/lib/rts.js --- a/lib/rts.js +++ b/lib/rts.js @@ -11,13 +11,16 @@ */ function T(f) { - this.f = new F(f); + this.f = f; } function F(f) { this.f = f; } +// Special object used for blackholing. +var __blackhole = {}; + /* Apply Applies the function f to the arguments args. If the application is under- saturated, a closure is returned, awaiting further arguments. If it is over- @@ -68,12 +71,12 @@ */ function E(t) { if(t instanceof T) { - if(t.f instanceof F) { - var f = t.f.f; - t.f = 0; - t.f = f(); + if(t.f != __blackhole) { + var f = t.f; + t.f = __blackhole; + t.x = f(); } - return t.f; + return t.x; } else { return t; } @@ -85,7 +88,7 @@ function B(f) { while(f instanceof F) { var fun = f.f; - f = 0; + f = __blackhole; f = fun(); } return f; diff --git a/lib/stdlib.js b/lib/stdlib.js --- a/lib/stdlib.js +++ b/lib/stdlib.js @@ -163,6 +163,24 @@ return [0]; } +function jsQuerySelectorAll(elem, query) { + var els = [0], + len, nl, i; + + if (!elem || typeof elem.querySelectorAll !== 'function') { + return els; + } + + nl = elem.querySelectorAll(query); + len = nl.length; + + for (i=len-1; i >= 0; --i) { + els = [1, [0, nl[i]], els]; + } + + return els; +} + function jsCreateElem(tag) { return document.createElement(tag); } diff --git a/libraries/haste-lib/src/Haste/DOM.hs b/libraries/haste-lib/src/Haste/DOM.hs --- a/libraries/haste-lib/src/Haste/DOM.hs +++ b/libraries/haste-lib/src/Haste/DOM.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, CPP #-} +{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, CPP, + GeneralizedNewtypeDeriving #-} module Haste.DOM ( Elem (..), PropID, ElemID, newElem, newTextElem, - elemById, setProp, getProp, setAttr, getAttr, setProp', - getProp', getValue, withElem , withElems, addChild, - addChildBefore, removeChild, clearChildren , getChildBefore, + elemById, elemsByQS, + setProp, getProp, setAttr, getAttr, setProp', getProp', getValue, + withElem , withElems, withElemsQS, mapQS, mapQS_, + addChild, addChildBefore, removeChild, clearChildren , getChildBefore, getFirstChild, getLastChild, getChildren, setChildren, getStyle, setStyle, getStyle', setStyle', getFileData, getFileName, setClass, toggleClass, hasClass, click, focus, blur, - documentBody + document, documentBody ) where import Haste.Prim import Haste.JSType @@ -21,11 +23,11 @@ import System.IO.Unsafe (unsafePerformIO) newtype Elem = Elem JSAny -instance Pack Elem -instance Unpack Elem + deriving (Pack, Unpack) type PropID = String type ElemID = String +type QuerySelector = String #ifdef __HASTE__ foreign import ccall jsGet :: Elem -> JSString -> IO JSString @@ -35,6 +37,7 @@ foreign import ccall jsGetStyle :: Elem -> JSString -> IO JSString foreign import ccall jsSetStyle :: Elem -> JSString -> JSString -> IO () foreign import ccall jsFind :: JSString -> IO (Ptr (Maybe Elem)) +foreign import ccall jsQuerySelectorAll :: Elem -> JSString -> IO (Ptr [Elem]) foreign import ccall jsCreateElem :: JSString -> IO Elem foreign import ccall jsCreateTextNode :: JSString -> IO Elem foreign import ccall jsAppendChild :: Elem -> Elem -> IO () @@ -54,6 +57,7 @@ jsGetStyle = error "Tried to use jsGetStyle on server side!" jsSetStyle = error "Tried to use jsSetStyle on server side!" jsFind = error "Tried to use jsFind on server side!" +jsQuerySelectorAll = error "Tried to use jsQuerySelectorAll on server side!" jsCreateElem = error "Tried to use jsCreateElem on server side!" jsCreateTextNode = error "Tried to use jsCreateTextNode on server side!" jsAppendChild = error "Tried to use jsAppendChild on server side!" @@ -157,6 +161,10 @@ elemById :: MonadIO m => ElemID -> m (Maybe Elem) elemById eid = liftIO $ fromPtr `fmap` (jsFind $ toJSStr eid) +-- | Get all children elements matching a query selector. +elemsByQS :: MonadIO m => Elem -> QuerySelector -> m [Elem] +elemsByQS el sel = liftIO $ fromPtr `fmap` (jsQuerySelectorAll el (toJSStr sel)) + -- | Perform an IO action on an element. withElem :: MonadIO m => ElemID -> (Elem -> m a) -> m a withElem e act = do @@ -179,6 +187,19 @@ findElems (_:is) (_:mes) = findElems is mes findElems _ _ = [] +-- | Perform an IO action over the a list of elements matching a query +-- selector. +withElemsQS :: MonadIO m => Elem -> QuerySelector -> ([Elem] -> m a) -> m a +withElemsQS el sel act = elemsByQS el sel >>= act + +-- | Map an IO computation over the list of elements matching a query selector. +mapQS :: MonadIO m => Elem -> QuerySelector -> (Elem -> m a) -> m [a] +mapQS el sel act = elemsByQS el sel >>= mapM act + +-- | Like @mapQS@ but returns no value. +mapQS_ :: MonadIO m => Elem -> QuerySelector -> (Elem -> m a) -> m () +mapQS_ el sel act = elemsByQS el sel >>= mapM_ act + -- | Remove all children from the given element. clearChildren :: MonadIO m => Elem -> m () clearChildren = liftIO . jsClearChildren @@ -261,6 +282,14 @@ {-# NOINLINE blur' #-} blur' :: Elem -> IO () blur' = ffi "(function(e) {e.blur();})" + +-- | The DOM node corresponding to document. +document :: Elem +document = unsafePerformIO getDocument + where + {-# NOINLINE getDocument #-} + getDocument :: IO Elem + getDocument = ffi "document" -- | The DOM node corresponding to document.body. documentBody :: Elem diff --git a/libraries/haste-lib/src/Haste/Foreign.hs b/libraries/haste-lib/src/Haste/Foreign.hs --- a/libraries/haste-lib/src/Haste/Foreign.hs +++ b/libraries/haste-lib/src/Haste/Foreign.hs @@ -15,8 +15,6 @@ import System.IO.Unsafe import Unsafe.Coerce -import Debug.Trace - #ifdef __HASTE__ foreign import ccall eval :: JSString -> IO (Ptr a) foreign import ccall "String" jsString :: Double -> JSString diff --git a/libraries/haste-lib/src/Haste/Graphics/Canvas.hs b/libraries/haste-lib/src/Haste/Graphics/Canvas.hs --- a/libraries/haste-lib/src/Haste/Graphics/Canvas.hs +++ b/libraries/haste-lib/src/Haste/Graphics/Canvas.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, - TypeSynonymInstances, FlexibleInstances, GADTs, CPP #-} + TypeSynonymInstances, FlexibleInstances, GADTs, CPP, + GeneralizedNewtypeDeriving #-} -- | Basic Canvas graphics library. module Haste.Graphics.Canvas ( -- Types @@ -22,12 +23,16 @@ -- Creating shapes line, path, rect, circle, arc, -- Working with text - font, text + font, text, + -- Extending the library + withContext ) where import Control.Applicative import Control.Monad.IO.Class +import System.IO.Unsafe import Haste import Haste.Concurrent (CIO) -- for SPECIALISE pragma +import Haste.Foreign (Pack (..), Unpack (..)) #ifdef __HASTE__ foreign import ccall jsHasCtx2D :: Elem -> IO Bool @@ -78,7 +83,10 @@ jsCanvasToDataURL = error "Tried to use Canvas in native code!" #endif +-- | A bitmap, backed by an IMG element. +-- JS representation is a reference to the backing IMG element. newtype Bitmap = Bitmap Elem + deriving (Pack, Unpack) -- | Any type that contains a buffered image which can be drawn onto a canvas. class ImageBuffer a where @@ -154,25 +162,61 @@ toJSString a, ")"] -- | A drawing context; part of a canvas. +-- JS representation is the drawing context object itself. newtype Ctx = Ctx JSAny + deriving (Pack, Unpack) -- | A canvas; a viewport into which a picture can be rendered. -- The origin of the coordinate system used by the canvas is the top left -- corner of the canvas element. +-- JS representation is a reference to the backing canvas element. data Canvas = Canvas Ctx Elem +instance Pack Canvas where + pack c = + case unsafePerformIO . getCanvas $ pack c of + Just c' -> c' + _ -> error "Attempted to pack a non-canvas element into a Canvas!" + +instance Unpack Canvas where + unpack (Canvas _ el) = unpack el + -- | A picture that can be drawn onto a canvas. newtype Picture a = Picture {unP :: Ctx -> IO a} -- | A shape which can be either stroked or filled to yield a picture. newtype Shape a = Shape {unS :: Ctx -> IO a} +instance Functor Picture where + fmap f p = Picture $ \ctx -> + unP p ctx >>= return . f + +instance Applicative Picture where + pure a = Picture $ \_ -> return a + + pfab <*> pa = Picture $ \ctx -> do + fab <- unP pfab ctx + a <- unP pa ctx + return (fab a) + instance Monad Picture where return x = Picture $ \_ -> return x Picture m >>= f = Picture $ \ctx -> do x <- m ctx unP (f x) ctx +instance Functor Shape where + fmap f s = Shape $ \ctx -> + unS s ctx >>= return . f + +instance Applicative Shape where + pure a = Shape $ \_ -> return a + + sfab <*> sa = Shape $ \ctx -> do + fab <- unS sfab ctx + a <- unS sa ctx + return (fab a) + instance Monad Shape where return x = Shape $ \_ -> return x Shape m >>= f = Shape $ \ctx -> do @@ -187,7 +231,7 @@ -- | Create a 2D drawing context from a DOM element. getCanvas :: MonadIO m => Elem -> m (Maybe Canvas) -getCanvas e = liftIO $ do +getCanvas e = liftIO $ do hasCtx <- jsHasCtx2D e case hasCtx of True -> do @@ -232,6 +276,12 @@ return $ Bitmap el _ -> do Bitmap <$> newElem "img" + +-- | Perform a computation over the drawing context of the picture. +-- This is handy for operations which are either impossible, hard or +-- inefficient to express using the Haste.Graphics.Canvas API. +withContext :: (Ctx -> IO a) -> Picture a +withContext f = Picture $ \ctx -> f ctx -- | Set a new color for strokes. setStrokeColor :: Color -> Picture () diff --git a/src/Haste/Config.hs b/src/Haste/Config.hs --- a/src/Haste/Config.hs +++ b/src/Haste/Config.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, Rank2Types #-} +{-# LANGUAGE OverloadedStrings, Rank2Types, PatternGuards #-} module Haste.Config ( Config (..), AppStart, def, stdJSLibs, startCustom, fastMultiply, safeMultiply, debugLib) where @@ -10,7 +10,7 @@ import Haste.Environment import Outputable (Outputable) import Data.Default -import Data.List (isPrefixOf, nub) +import Data.List (stripPrefix, nub) type AppStart = Builder -> Builder @@ -42,11 +42,10 @@ -- | Replace the first occurrence of $HASTE_MAIN with Haste's entry point -- symbol. insertSym :: String -> AppStart -insertSym [] _ = fromString "" +insertSym [] _ = fromString "" insertSym str sym - | "$HASTE_MAIN" `isPrefixOf` str = sym <> fromString str - | otherwise = case span (/= '$') str of - (l,r) -> fromString l <> insertSym r sym + | Just r <- stripPrefix "$HASTE_MAIN" str = sym <> fromString r + | (l,r) <- span (/= '$') str = fromString l <> insertSym r sym -- | Execute the program when the document has finished loading. startOnLoadComplete :: AppStart diff --git a/src/Haste/Version.hs b/src/Haste/Version.hs --- a/src/Haste/Version.hs +++ b/src/Haste/Version.hs @@ -9,7 +9,7 @@ import Haste.Environment (hasteSysDir, ghcBinary) hasteVersion :: Version -hasteVersion = Version [0, 4, 2, 1] [] +hasteVersion = Version [0, 4, 3] [] ghcVersion :: String ghcVersion = unsafePerformIO $ do diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -112,7 +112,7 @@ and args' where args' = [not $ any (`isSuffixOf` a) someoneElsesProblems | a <- args] - someoneElsesProblems = [".c", ".cmm", ".hs-boot", ".lhs-boot"] + someoneElsesProblems = [".c", ".cmm"] -- | The main compiler driver. compiler :: Bool -> [String] -> IO () diff --git a/src/haste-cat.hs b/src/haste-cat.hs new file mode 100644 --- /dev/null +++ b/src/haste-cat.hs @@ -0,0 +1,33 @@ +module Main where +import System.Environment +import Haste.Module +import Haste.Config +import Data.JSTarget +import Data.JSTarget.PP +import Data.Maybe +import qualified Data.Map as M +import qualified Data.ByteString.Lazy.Char8 as BS + +main = do + as <- getArgs + if null as + then putStrLn "Usage: haste-cat package-id:Module.To.Inspect" + else mapM_ printModule as + +printModule mpkg = do + let (pkg, (_:m)) = break (== ':') mpkg + mods <- mapM (\p -> readModule p pkg m) ("." : libPaths def) + mapM_ printDefs . map fromJust $ filter isJust mods + +printDefs mod = do + mapM_ printDef $ M.toList $ modDefs mod + +printDef (name, def) = do + putStrLn $ niceName name + BS.putStrLn $ pretty debugPPOpts def + putStrLn "" + +niceName (Name n (Just (pkg, m))) = + pkg ++ ":" ++ m ++ "." ++ n +niceName (Name n _) = + n