packages feed

haste-compiler 0.4.2 → 0.4.2.1

raw patch · 10 files changed

+254/−89 lines, 10 filesdep +network-uridep ~networkdep ~websockets

Dependencies added: network-uri

Dependency ranges changed: network, websockets

Files

haste-compiler.cabal view
@@ -1,5 +1,5 @@ Name:           haste-compiler-Version:        0.4.2+Version:        0.4.2.1 License:        BSD3 License-File:   LICENSE Synopsis:       Haskell To ECMAScript compiler@@ -62,6 +62,7 @@         bzlib,         transformers,         network,+        network-uri,         HTTP,         shellmate >= 0.1.5,         ghc-paths,@@ -235,7 +236,6 @@         binary,         data-binary-ieee754,         bytestring >= 0.9.2.1,-        websockets >= 0.8,         utf8-string,         -- For Haste.Compiler         shellmate >= 0.1.5,@@ -246,4 +246,13 @@         ghc-paths,         ghc,         directory+    -- websockets-0.9 is broken on Windows+    if os(windows)+        Build-Depends:+            websockets >= 0.8 && < 0.9,+            network < 2.6,+            network-uri < 2.6+    else+        Build-Depends:+            websockets >= 0.8     Default-Language: Haskell98
lib/rts.js view
@@ -69,21 +69,24 @@ function E(t) {     if(t instanceof T) {         if(t.f instanceof F) {-            return t.f = t.f.f();-        } else {-            return t.f;+            var f = t.f.f;+            t.f = 0;+            t.f = f();         }+        return t.f;     } else {         return t;     } }  /* Bounce-   Bonuce on a trampoline for as long as we get a function back.+   Bounce on a trampoline for as long as we get a function back. */ function B(f) {     while(f instanceof F) {-        f = f.f();+        var fun = f.f;+        f = 0;+        f = fun();     }     return f; }@@ -117,12 +120,16 @@ // 32 bit integer multiplication, with correct overflow behavior // note that |0 or >>>0 needs to be applied to the result, for int and word // respectively.-function imul(a, b) {-  // ignore high a * high a as the result will always be truncated-  var lows = (a & 0xffff) * (b & 0xffff); // low a * low b-  var aB = (a & 0xffff) * (b & 0xffff0000); // low a * high b-  var bA = (a & 0xffff0000) * (b & 0xffff); // low b * high a-  return lows + aB + bA; // sum will not exceed 52 bits, so it's safe+if(Math.imul) {+    var imul = Math.imul;+} else {+    var imul = function(a, b) {+        // ignore high a * high a as the result will always be truncated+        var lows = (a & 0xffff) * (b & 0xffff); // low a * low b+        var aB = (a & 0xffff) * (b & 0xffff0000); // low a * high b+        var bA = (a & 0xffff0000) * (b & 0xffff); // low b * high a+        return lows + aB + bA; // sum will not exceed 52 bits, so it's safe+    } }  function addC(a, b) {@@ -254,11 +261,11 @@  function localeEncoding() {     var le = newByteArr(5);-    le['b']['i8'] = 'U'.charCodeAt(0);-    le['b']['i8'] = 'T'.charCodeAt(0);-    le['b']['i8'] = 'F'.charCodeAt(0);-    le['b']['i8'] = '-'.charCodeAt(0);-    le['b']['i8'] = '8'.charCodeAt(0);+    le['v']['i8'][0] = 'U'.charCodeAt(0);+    le['v']['i8'][1] = 'T'.charCodeAt(0);+    le['v']['i8'][2] = 'F'.charCodeAt(0);+    le['v']['i8'][3] = '-'.charCodeAt(0);+    le['v']['i8'][4] = '8'.charCodeAt(0);     return le; }
libraries/haste-lib/src/Haste/Binary.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE MagicHash, CPP, MultiParamTypeClasses, OverloadedStrings,              TypeSynonymInstances , FlexibleInstances, OverlappingInstances,-             GeneralizedNewtypeDeriving #-}+             GeneralizedNewtypeDeriving, BangPatterns, TypeOperators, KindSignatures, DefaultSignatures, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, ScopedTypeVariables #-} -- | Handling of Javascript-native binary blobs.+--+-- Generics borrowed from the binary package by Lennart Kolmodin (released under BSD3) module Haste.Binary (     module Haste.Binary.Put,     module Haste.Binary.Get,@@ -20,6 +22,8 @@ import Haste.Binary.Put import Haste.Binary.Get import Control.Applicative+import GHC.Generics+import Data.Bits  class Monad m => MonadBlob m where   -- | Retrieve the raw data from a blob.@@ -43,7 +47,7 @@ #else       mkBlobData = undefined #endif-      +       convertBlob :: Blob -> Opaque (Unpacked -> IO ()) -> IO ()       convertBlob = ffi         "(function(b,cb){var r=new FileReader();r.onload=function(){B(A(cb,[new DataView(r.result),0]));};r.readAsArrayBuffer(b);})"@@ -65,6 +69,17 @@   get :: Get a   put :: a -> Put +  default put :: (Generic a, GBinary (Rep a)) => a -> Put+  put = gput . from++  default get :: (Generic a, GBinary (Rep a)) => Get a+  get = to `fmap` gget++-- | Generic version+class GBinary f where+    gput :: f t -> Put+    gget :: Get (f t)+ instance Binary Word8 where   put = putWord8   get = getWord8@@ -160,3 +175,112 @@  decode :: Binary a => BlobData -> Either String a decode = runGet get+++-- Type without constructors+instance GBinary V1 where+    gput _ = return ()+    gget   = return undefined++-- Constructor without arguments+instance GBinary U1 where+    gput U1 = return ()+    gget    = return U1++-- Product: constructor with parameters+instance (GBinary a, GBinary b) => GBinary (a :*: b) where+    gput (x :*: y) = gput x >> gput y+    gget = (:*:) <$> gget <*> gget++-- Metadata (constructor name, etc)+instance GBinary a => GBinary (M1 i c a) where+    gput = gput . unM1+    gget = M1 <$> gget++-- Constants, additional parameters, and rank-1 recursion+instance Binary a => GBinary (K1 i a) where+    gput = put . unK1+    gget = K1 <$> get++-- Borrowed from the cereal package.++-- The following GBinary instance for sums has support for serializing+-- types with up to 2^64-1 constructors. It will use the minimal+-- number of bytes needed to encode the constructor. For example when+-- a type has 2^8 constructors or less it will use a single byte to+-- encode the constructor. If it has 2^16 constructors or less it will+-- use two bytes, and so on till 2^64-1.+--+-- NB: changed to 2^32-1 constructors++#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)+#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)+#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)++instance ( GSum     a, GSum     b+         , GBinary a, GBinary b+         , SumSize    a, SumSize    b) => GBinary (a :+: b) where+    gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) -- | PUTSUM(Word64)+         | otherwise = sizeError "encode" size+      where+        size = unTagged (sumSize :: Tagged (a :+: b) Word32)+    {-# INLINE gput #-}++    gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) -- | GETSUM(Word64)+         | otherwise = sizeError "decode" size+      where+        size = unTagged (sumSize :: Tagged (a :+: b) Word32)+    {-# INLINE gget #-}++sizeError :: Show size => String -> size -> error+sizeError s size =+    error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors"++------------------------------------------------------------------------++checkGetSum :: (Ord word, Num word, Bits word, GSum f)+            => word -> word -> Get (f a)+checkGetSum size code | code < size = getSum code size+                      | otherwise   = fail "Unknown encoding for constructor"+{-# INLINE checkGetSum #-}++class GSum f where+    getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)+    putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put++instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where+    getSum !code !size | code < sizeL = L1 <$> getSum code           sizeL+                       | otherwise    = R1 <$> getSum (code - sizeL) sizeR+        where+          sizeL = size `shiftR` 1+          sizeR = size - sizeL+    {-# INLINE getSum #-}++    putSum !code !size s = case s of+                             L1 x -> putSum code           sizeL x+                             R1 x -> putSum (code + sizeL) sizeR x+        where+          sizeL = size `shiftR` 1+          sizeR = size - sizeL+    {-# INLINE putSum #-}++instance GBinary a => GSum (C1 c a) where+    getSum _ _ = gget+    {-# INLINE getSum #-}++    putSum !code _ x = put code *> gput x+    {-# INLINE putSum #-}++------------------------------------------------------------------------++class SumSize f where+    sumSize :: Tagged f Word32++newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}++instance (SumSize a, SumSize b) => SumSize (a :+: b) where+    sumSize = Tagged $ unTagged (sumSize :: Tagged a Word32) ++                       unTagged (sumSize :: Tagged b Word32)++instance SumSize (C1 c a) where+    sumSize = Tagged 1
src/Data/JSTarget.hs view
@@ -4,7 +4,7 @@     PPOpts (..), pretty, runPP, prettyProg, def,     Arity, Comment, Shared, Name (..), Var (..), LHS, Call,     Lit, Exp, Stm, Alt, AST (..), Module (..),-    foreignModule, moduleOf, pkgOf, blackHole, blackHoleVar+    foreignModule, moduleOf, pkgOf, blackHole, blackHoleVar, merge   ) where import Data.JSTarget.AST import Data.JSTarget.Op as Op
src/Data/JSTarget/AST.hs view
@@ -1,7 +1,11 @@-{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, FlexibleInstances #-}+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, FlexibleInstances, CPP #-} module Data.JSTarget.AST where import qualified Data.Set as S+#if __GLASGOW_HASKELL__ >= 708+import qualified Data.Map.Strict as M+#else import qualified Data.Map as M+#endif import System.IO.Unsafe import System.Random (randomIO) import Data.IORef@@ -16,7 +20,7 @@ -- | Shared statements. newtype Shared a = Shared Lbl deriving (Eq, Show) -data Name = Name String (Maybe (String, String)) deriving (Eq, Ord, Show)+data Name = Name !String !(Maybe (String, String)) deriving (Eq, Ord, Show)  class HasModule a where   moduleOf :: a -> Maybe String@@ -34,8 +38,8 @@  -- | Representation of variables. data Var where-  Foreign  :: String -> Var-  Internal :: Name -> Comment -> Var+  Foreign  :: !String -> Var+  Internal :: !Name -> !Comment -> Var   deriving (Show)  instance Eq Var where@@ -53,8 +57,8 @@ --   but for some primops we need to assign array elements as well. --   LhsExp is never reorderable. data LHS where-  NewVar :: Reorderable -> Var -> LHS-  LhsExp :: Exp -> LHS+  NewVar :: !Reorderable -> !Var -> LHS+  LhsExp :: !Exp -> LHS   deriving (Eq, Show)  -- | Distinguish between normal, optimized and method calls.@@ -63,48 +67,48 @@ --   only be set to False when there is absolutely no possibility whatsoever --   that the called function will tailcall. data Call where-  Normal   :: Bool -> Call-  Fast     :: Bool -> Call-  Method   :: String -> Call+  Normal   :: !Bool -> Call+  Fast     :: !Bool -> Call+  Method   :: !String -> Call   deriving (Eq, Show)  -- | Literals; nothing fancy to see here. data Lit where-  LNum  :: Double  -> Lit-  LStr  :: String  -> Lit-  LBool :: Bool    -> Lit-  LInt  :: Integer -> Lit+  LNum  :: !Double  -> Lit+  LStr  :: !String  -> Lit+  LBool :: !Bool    -> Lit+  LInt  :: !Integer -> Lit   LNull :: Lit   deriving (Eq, Show)  -- | Expressions. Completely predictable. data Exp where-  Var       :: Var -> Exp-  Lit       :: Lit -> Exp-  Not       :: Exp -> Exp-  BinOp     :: BinOp -> Exp -> Exp -> Exp-  Fun       :: Maybe Name -> [Var] -> Stm -> Exp-  Call      :: Arity -> Call -> Exp -> [Exp] -> Exp-  Index     :: Exp -> Exp -> Exp-  Arr       :: [Exp] -> Exp-  AssignEx  :: Exp -> Exp -> Exp-  IfEx      :: Exp -> Exp -> Exp -> Exp-  Eval      :: Exp -> Exp-  Thunk     :: Stm -> Exp+  Var       :: !Var -> Exp+  Lit       :: !Lit -> Exp+  Not       :: !Exp -> Exp+  BinOp     :: !BinOp -> Exp -> !Exp -> Exp+  Fun       :: !(Maybe Name) -> ![Var] -> !Stm -> Exp+  Call      :: !Arity -> !Call -> !Exp -> ![Exp] -> Exp+  Index     :: !Exp -> !Exp -> Exp+  Arr       :: ![Exp] -> Exp+  AssignEx  :: !Exp -> !Exp -> Exp+  IfEx      :: !Exp -> !Exp -> !Exp -> Exp+  Eval      :: !Exp -> Exp+  Thunk     :: !Stm -> Exp   deriving (Eq, Show)  -- | Statements. The only mildly interesting thing here are the Case and Jump --   constructors, which allow explicit sharing of continuations. data Stm where-  Case     :: Exp -> Stm -> [Alt] -> Shared Stm -> Stm-  Forever  :: Stm -> Stm-  Assign   :: LHS -> Exp -> Stm -> Stm-  Return   :: Exp -> Stm+  Case     :: !Exp -> !Stm -> ![Alt] -> !(Shared Stm) -> Stm+  Forever  :: !Stm -> Stm+  Assign   :: !LHS -> !Exp -> !Stm -> Stm+  Return   :: !Exp -> Stm   Cont     :: Stm-  Jump     :: Shared Stm -> Stm+  Jump     :: !(Shared Stm) -> Stm   NullRet  :: Stm-  Tailcall :: Exp -> Stm-  ThunkRet :: Exp -> Stm -- Return from a Thunk+  Tailcall :: !Exp -> Stm+  ThunkRet :: !Exp -> Stm -- Return from a Thunk   deriving (Eq, Show)  -- | Case alternatives - an expression to match and a branch.@@ -120,6 +124,17 @@     modDefs        :: !(M.Map Name (AST Exp))   } +-- | Merge two modules. The module and package IDs of the second argument are+--   used, and the second argument will take precedence for symbols which exist+--   in both.+merge :: Module -> Module -> Module+merge m1 m2 = Module {+    modPackageId = modPackageId m2,+    modName = modName m2,+    modDeps = M.union (modDeps m1) (modDeps m2),+    modDefs = M.union (modDefs m1) (modDefs m2)+  }+ -- | Imaginary module for foreign code that may need one. foreignModule :: Module foreignModule = Module {@@ -141,8 +156,8 @@  -- | An AST with local jumps. data AST a = AST {-    astCode  :: a,-    astJumps :: JumpTable+    astCode  :: !a,+    astJumps :: !JumpTable   } deriving (Show, Eq)  instance Functor AST where
src/Data/JSTarget/Traversal.hs view
@@ -7,7 +7,7 @@ import Data.Map as M ((!), insert)  -- | AST nodes we'd like to fold and map over.-data ASTNode = Exp Exp | Stm Stm | Label Lbl+data ASTNode = Exp !Exp | Stm !Stm | Label !Lbl  newtype TravM a = T (JumpTable -> (JumpTable, a)) instance Monad TravM where
src/Haste/Module.hs view
@@ -8,12 +8,12 @@ import Data.Binary  -- | The file extension to use for modules.-jsmodExt :: String-jsmodExt = "jsmod"+jsmodExt :: Bool -> String+jsmodExt boot = if boot then "jsmod-boot" else "jsmod" -moduleFilePath :: FilePath -> String -> String -> FilePath-moduleFilePath basepath pkgid modname =-  flip addExtension jsmodExt $+moduleFilePath :: FilePath -> String -> String -> Bool -> FilePath+moduleFilePath basepath pkgid modname boot =+  flip addExtension (jsmodExt boot) $     basepath </> pkgid </> (moduleNameSlashes $ mkModuleName modname)  -- | Write a module to file, with the extension specified in `fileExt`.@@ -21,19 +21,28 @@ --   basepath/Foo/Bar.jsmod --   If any directory in the path where the module is to be written doesn't --   exist, it gets created.-writeModule :: FilePath -> Module -> IO ()-writeModule basepath m@(Module pkgid modname _ _) =+writeModule :: FilePath -> Module -> Bool -> IO ()+writeModule basepath m@(Module pkgid modname _ _) boot =   fromRight "writeModule" . shell $ do     mkdir True (takeDirectory path)     liftIO $ B.writeFile path (encode m)   where-    path = moduleFilePath basepath pkgid modname+    path = moduleFilePath basepath pkgid modname boot  -- | Read a module from file. If the module is not found at the specified path,---   libpath/path is tried instead. Panics if the module is found on neither---   path.+--   libpath/path is tried instead. Returns Nothing is the module is not found+--   on either path. readModule :: FilePath -> String -> String -> IO (Maybe Module) readModule basepath pkgid modname = fromRight "readModule" . shell $ do+  mm <- readMod basepath pkgid modname False+  mmboot <- readMod basepath pkgid modname True+  case (mm, mmboot) of+    (Just m, Nothing)    -> return $ Just m+    (Just m, Just mboot) -> return . Just $ merge mboot m+    _                    -> return Nothing++readMod :: FilePath -> String -> String -> Bool -> Shell (Maybe Module)+readMod basepath pkgid modname boot = do     x <- isFile path     let path' = if x then path else syspath     isF <- isFile path'@@ -41,8 +50,8 @@        then Just . decode <$> liftIO (B.readFile path')        else return Nothing   where-    path = moduleFilePath "." pkgid modname-    syspath = moduleFilePath basepath pkgid modname+    path = moduleFilePath "." pkgid modname boot+    syspath = moduleFilePath basepath pkgid modname boot  fromRight :: String -> IO (Either String b) -> IO b fromRight from m = do
src/Haste/Monad.hs view
@@ -12,19 +12,19 @@     deps         :: !(S.Set Name),     locals       :: !(S.Set Name),     continuation :: !(AST Stm -> AST Stm),-    bindStack    :: [Var],-    modName      :: String,-    config       :: cfg+    bindStack    :: ![Var],+    modName      :: !String,+    config       :: !cfg   } -initialState :: GenState cfg-initialState = GenState {+initialState :: cfg -> GenState cfg+initialState cfg = GenState {     deps         = S.empty,     locals       = S.empty,     continuation = id,     bindStack    = [],-    modName      = undefined,-    config       = undefined+    modName      = "",+    config       = cfg   }  newtype JSGen cfg a =@@ -65,7 +65,7 @@       -> JSGen cfg a -- ^ The code generation computation.       -> (a, S.Set J.Name, S.Set J.Name, AST Stm -> AST Stm) genJS cfg myModName (JSGen gen) =-  case runState gen initialState {modName = myModName, config = cfg} of+  case runState gen (initialState cfg) {modName = myModName} of     (a, GenState dependencies loc cont _ _ _) ->       (a, dependencies, loc, cont)
src/Haste/Version.hs view
@@ -9,7 +9,7 @@ import Haste.Environment (hasteSysDir, ghcBinary)  hasteVersion :: Version-hasteVersion = Version [0, 4, 2] []+hasteVersion = Version [0, 4, 2, 1] []  ghcVersion :: String ghcVersion = unsafePerformIO $ do
src/Main.hs view
@@ -233,22 +233,23 @@ -- | Compile a module into a .jsmod intermediate file. compile :: (GhcMonad m) => Config -> DynFlags -> ModSummary -> m () compile cfg dynflags modSummary = do-    case ms_hsc_src modSummary of-      HsBootFile -> liftIO $ logStr cfg $ "Skipping boot " ++ myName-      _          -> do-        (pgm, name) <- prepare dynflags modSummary+    let boot = case ms_hsc_src modSummary of+                 HsBootFile -> True+                 _          -> False+    (pgm, name) <- prepare dynflags modSummary #if __GLASGOW_HASKELL__ >= 706-        let pkgid = showPpr dynflags $ modulePackageId $ ms_mod modSummary-            cfg' = cfg {showOutputable = showPpr dynflags}+    let pkgid = showPpr dynflags $ modulePackageId $ ms_mod modSummary+        cfg' = cfg {showOutputable = showPpr dynflags} #else-        let pkgid = showPpr $ modulePackageId $ ms_mod modSummary-            cfg' = cfg {showOutputable = showPpr}+    let pkgid = showPpr $ modulePackageId $ ms_mod modSummary+        cfg' = cfg {showOutputable = showPpr} #endif-            theCode = generate cfg' pkgid name pgm-        liftIO $ logStr cfg $ "Compiling " ++ myName ++ " into " ++ targetpath-        liftIO $ writeModule targetpath theCode+        theCode = generate cfg' pkgid name pgm+    liftIO $ logStr cfg $ "Compiling " ++ myName boot ++ " into " ++ targetpath+    liftIO $ writeModule targetpath theCode boot   where-    myName = moduleNameString $ moduleName $ ms_mod modSummary+    myName False = moduleNameString $ moduleName $ ms_mod modSummary+    myName True = myName False ++ " [boot]"     targetpath = targetLibPath cfg  -- | Fill in linkage info, such as whether to link at all and what the program