packages feed

haste-compiler 0.4.2.1 → 0.4.3

raw patch · 10 files changed

+184/−30 lines, 10 filesdep ~bytestringdep ~networkdep ~network-urinew-component:exe:haste-cat

Dependency ranges changed: bytestring, network, network-uri

Files

haste-compiler.cabal view
@@ -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 <anton@ekblad.cc> 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
lib/rts.js view
@@ -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;
lib/stdlib.js view
@@ -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); }
libraries/haste-lib/src/Haste/DOM.hs view
@@ -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
libraries/haste-lib/src/Haste/Foreign.hs view
@@ -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
libraries/haste-lib/src/Haste/Graphics/Canvas.hs view
@@ -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 ()
src/Haste/Config.hs view
@@ -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
src/Haste/Version.hs view
@@ -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
src/Main.hs view
@@ -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 ()
+ src/haste-cat.hs view
@@ -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