packages feed

haste-compiler 0.2.7 → 0.2.8

raw patch · 14 files changed

+107/−52 lines, 14 filesdep +blaze-builderdep ~bytestringdep ~ghc

Dependencies added: blaze-builder

Dependency ranges changed: bytestring, ghc

Files

haste-compiler.cabal view
@@ -1,5 +1,5 @@ Name:           haste-compiler-Version:        0.2.7+Version:        0.2.8 License:        BSD3 License-File:   LICENSE Synopsis:       Haskell To ECMAScript compiler@@ -90,12 +90,13 @@     Build-Depends:         base < 5,         ghc-prim,-        ghc >= 7.6,+        ghc >= 7.4,         mtl,         binary,         containers,         data-default,-        bytestring >= 0.10.0.0,+        bytestring >= 0.9.2.1,+        blaze-builder,         filepath,         directory,         array,
src/Control/Shell.hs view
@@ -7,7 +7,7 @@     run, run_, run', runInteractive,     cd, cpDir, pwd, ls, mkdir, rmdir, inDirectory, isDirectory,     withHomeDirectory, inHomeDirectory, withAppDirectory, inAppDirectory,-    isFile, rm, mv, cp, file, mtime,+    isFile, rm, mv, cp, file,     withTempFile, withTempDirectory, inTempDirectory,     module System.FilePath,   ) where@@ -217,10 +217,6 @@ ls dir = do   contents <- liftIO $ Dir.getDirectoryContents dir   return [f | f <- contents, f /= ".", f /= ".."]---- | Get the last time the given file was modified in UTC.-mtime :: FilePath -> Shell UTCTime-mtime = liftIO . Dir.getModificationTime  -- | Create a directory. Optionally create any required missing directories as --   well.
src/Data/JSTarget/AST.hs view
@@ -188,7 +188,8 @@     AST r (M.singleton r s')   where     freshRef = return $! unsafePerformIO $! do-      r <- atomicModifyIORef' nextLbl (\lbl -> (lbl+1, Lbl lblNamespace lbl))+      r <- atomicModifyIORef nextLbl $ \lbl ->+        lbl `seq` (lbl+1, Lbl lblNamespace lbl)       -- We need to depend on s, or GHC will hoist us out of lblFor, possibly       -- causing circular dependencies between expressions.       return (r, s)
src/Data/JSTarget/PP.hs view
@@ -13,10 +13,10 @@ import Control.Applicative import qualified Data.Map as M import qualified Data.ByteString.Lazy as BS-import Data.ByteString.Lazy.Builder-import Data.ByteString.Lazy.Builder.ASCII import Data.JSTarget.AST (AST (..), Name (..), JumpTable, Lbl, Stm) import Data.JSTarget.Traversal (JSTrav)+import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char.Utf8 as B  -- | Pretty-printing options data PPOpts = PPOpts {@@ -37,6 +37,10 @@ emptyNS :: NameSupply emptyNS = (FinalName 0, M.empty) +intDec = B.fromString . show+doubleDec = B.fromString . show+integerDec = B.fromString . show+ newtype PP a = PP {unPP :: PPOpts                         -> IndentLvl                         -> NameSupply@@ -120,16 +124,16 @@ -- | Turn a FinalName into a Builder. buildFinalName :: FinalName -> Builder buildFinalName (FinalName 0) =-    string7 "_0"+    B.fromString "_0" buildFinalName (FinalName fn) =-    char7 '_' <> go fn mempty+    fromChar '_' <> go fn mempty   where       arrLen = 62       chars = listArray (0,arrLen-1)               $ "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"       go 0 acc = acc       go n acc = let (rest, ix) = n `quotRem` arrLen -                 in go rest (char7 (chars ! ix) <> acc)+                 in go rest (fromChar (chars ! ix) <> acc)  -- | Indent the given builder another step. indent :: PP a -> PP a@@ -144,9 +148,9 @@ instance Buildable Builder where   put x = PP $ \_ _ ns _ b -> (ns, b <> x, ()) instance Buildable String where-  put = put . stringUtf8+  put = put . B.fromString instance Buildable Char where-  put = put . char7+  put = put . fromChar instance Buildable Int where   put = put . intDec instance Buildable Double where@@ -157,7 +161,7 @@ instance Buildable Integer where   put = put . integerDec instance Buildable Bool where-  put x = put $ if x then string7 "true" else string7 "false"+  put x = put $ if x then B.fromString "true" else B.fromString "false"  -- | Emit indentation up to the current level. ind :: PP ()@@ -186,10 +190,10 @@   return ()  instance IsString Builder where-  fromString = stringUtf8+  fromString = B.fromString  instance IsString (PP ()) where-  fromString = put . stringUtf8+  fromString = put . B.fromString  -- | Pretty-printer class. Each part of the AST needs an instance of this. class Pretty a where
src/Data/JSTarget/Print.hs view
@@ -5,23 +5,20 @@ import Data.JSTarget.AST import Data.JSTarget.Op import Data.JSTarget.PP as PP-import Data.ByteString.Lazy.Builder+import Blaze.ByteString.Builder.Char.Utf8 import Data.Monoid import Control.Monad-import Data.List import Data.Char import Numeric (showHex) -import Debug.Trace- instance Pretty Var where   pp (Foreign name) =-    put $ string7 name+    put $ fromString name   pp (Internal name comment) = do     pp name     doComment <- getOpt nameComments     when (doComment && not (null comment)) $-      put $ "/* " <> stringUtf8 comment <> " */"+      put $ "/* " <> fromString comment <> " */"  instance Pretty Name where   pp name = finalNameFor name >>= put . buildFinalName@@ -222,7 +219,7 @@   let bparens = case b of                   Lit (LNum n) | n < 0 -> \x -> "(".+. pp x .+. ")"                   _                          -> parensR-  parensL a .+. put (string7 $ show op) .+. bparens b+  parensL a .+. put (fromString $ show op) .+. bparens b   where     parensL x = if expPrec x < opPrec op                   then "(" .+. pp x .+. ")"
src/Haste/CodeGen.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TupleSections, PatternGuards #-}+{-# LANGUAGE TupleSections, PatternGuards, CPP #-} module Haste.CodeGen (generate) where -- Misc. stuff import Control.Applicative@@ -129,7 +129,11 @@         StgPrimCallOp (PrimCall f _) ->           Right $ maybeTrace cfg fs args' $ callForeign fs args'           where fs = unpackFS f+#if __GLASGOW_HASKELL__ >= 706         StgFCallOp (CCall (CCallSpec (StaticTarget f _ _) _ _)) _t ->+#else+        StgFCallOp (CCall (CCallSpec (StaticTarget f _) _ _)) _t ->+#endif           Right $ maybeTrace cfg fs args' $ callForeign fs args'           where fs = unpackFS f         _ ->@@ -149,9 +153,13 @@   genEx ex genEx (StgTick _ _ ex) = do   genEx ex+#if __GLASGOW_HASKELL__ >= 706 genEx (StgLam _ _) = do   error "StgLam caught during code generation - that's impossible!"-+#else+genEx (StgLam _ _ _) = do+  error "StgLam caught during code generation - that's impossible!"+#endif -- | Trace the given expression, if tracing is on. maybeTrace :: Config -> String -> [AST Exp] -> AST Exp -> AST Exp maybeTrace cfg msg args ex =@@ -322,8 +330,13 @@  -- | Extracts the name of a foreign var. foreignName :: ForeignCall -> String+#if __GLASGOW_HASKELL__ >= 706 foreignName (CCall (CCallSpec (StaticTarget str _ _) _ _)) =   unpackFS str+#else+foreignName (CCall (CCallSpec (StaticTarget str _) _ _)) =+  unpackFS str+#endif foreignName _ =   error "Dynamic foreign calls not supported!" @@ -387,6 +400,11 @@ genArg :: StgArg -> JSGen Config (AST Exp) genArg (StgVarArg v)  = varExp <$> genVar v genArg (StgLitArg l)  = genLit l+#if __GLASGOW_HASKELL__ < 706+genArg (StgTypeArg t) = do+  warn Normal "Generated StgTypeArg as 0!"+  return (litN 0)+#endif  -- | Generate code for data constructor creation. Returns a pair of --   (constructor, field strictness annotations).
src/Haste/Config.hs view
@@ -4,8 +4,8 @@   safeMultiply, debugLib) where import Data.JSTarget import System.FilePath (replaceExtension, (</>))-import DynFlags-import Data.ByteString.Lazy.Builder+import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char.Utf8 import Data.Monoid import Haste.Environment @@ -36,9 +36,9 @@  -- | Replace the first occurrence of %% with Haste's entry point symbol. insertSym :: String -> AppStart-insertSym ('%':'%':str) sym = sym <> stringUtf8 str-insertSym (c:str) sym       = charUtf8 c <> insertSym str sym-insertSym [] _              = string7 ""+insertSym ('%':'%':str) sym = sym <> fromString str+insertSym (c:str) sym       = fromChar c <> insertSym str sym+insertSym [] _              = fromString ""  -- | Execute the program when the document has finished loading. startOnLoadComplete :: AppStart@@ -93,9 +93,7 @@     -- | Run the entire thing through Google Closure when done?     useGoogleClosure :: Maybe FilePath,     -- | Any external Javascript to link into the JS bundle.-    jsExternals :: [FilePath],-    -- | Dynamic flags used for compilation.-    dynFlags :: DynFlags+    jsExternals :: [FilePath]   }  -- | Default compiler configuration.@@ -116,6 +114,5 @@     sloppyTCE        = False,     tracePrimops     = False,     useGoogleClosure = Nothing,-    jsExternals      = [],-    dynFlags         = tracingDynFlags+    jsExternals      = []   }
src/Haste/Linker.hs view
@@ -8,7 +8,8 @@ import Control.Applicative import Data.JSTarget import qualified Data.ByteString.Lazy as B-import Data.ByteString.Lazy.Builder+import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char.Utf8 import Data.Monoid  -- | The program entry point.@@ -23,8 +24,8 @@   ds <- getAllDefs (libPath cfg) pkgid mainSym   let myDefs = if wholeProgramOpts cfg then topLevelInline ds else ds   let (progText, mainSym') = prettyProg (ppOpts cfg) mainSym myDefs-      callMain = string7 "A(" <> mainSym' <> string7 ", [0]);"-      launchApp = appStart cfg (string7 "hasteMain")+      callMain = fromString "A(" <> mainSym' <> fromString ", [0]);"+      launchApp = appStart cfg (fromString "hasteMain")      rtslibs <- mapM readFile $ rtsLibs cfg   extlibs <- mapM readFile $ jsExternals cfg@@ -33,18 +34,19 @@     $ assembleProg (wrapProg cfg) extlibs rtslibs progText callMain launchApp   where     assembleProg True extlibs rtslibs progText callMain launchApp =-      stringUtf8 (unlines extlibs)-      <> string7 "var hasteMain = function() {"-      <> stringUtf8 (unlines rtslibs)+      fromString (unlines extlibs)+      <> fromString "var hasteMain = function() {"+      <> fromString (unlines rtslibs)       <> progText       <> callMain-      <> string7 "};\n"+      <> fromString "};\n"       <> launchApp     assembleProg _ extlibs rtslibs progText callMain launchApp =-      stringUtf8 (unlines extlibs)-      <> stringUtf8 (unlines rtslibs)+      fromString (unlines extlibs)+      <> fromString (unlines rtslibs)       <> progText-      <> string7 "\nvar hasteMain = function() {" <> callMain <> string7 "};"+      <> fromString "\nvar hasteMain = function() {" <> callMain+                                                     <> fromString "};"       <> launchApp
src/Haste/PrimOps.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Haste.PrimOps (genOp) where import Prelude hiding (LT, GT) import PrimOp@@ -59,7 +60,9 @@     -- FIXME: this is correct but slow!     IntMulMayOfloOp -> intMath $ Right $ multiplyIntOp cfg (xs !! 0) (xs !! 1)     IntQuotOp ->       callF "quot"+#if __GLASGOW_HASKELL__ >= 706     IntQuotRemOp ->    callF "quotRemI"+#endif     IntRemOp ->        bOp Mod -- JS % operator is actually rem, not mod!     IntAddCOp -> callF "addC"     IntSubCOp -> callF "subC"@@ -78,7 +81,9 @@     WordSubOp ->  wordMath $ bOp Sub     WordMulOp ->  wordMath $ callF "imul"     WordQuotOp -> callF "quot"+#if __GLASGOW_HASKELL__ >= 706     WordQuotRemOp -> callF "quotRemI"+#endif     WordRemOp ->  bOp Mod     AndOp ->      wordMath $ bOp BitAnd     OrOp ->       wordMath $ bOp BitOr
src/Haste/Util.hs view
@@ -1,8 +1,13 @@+{-# LANGUAGE CPP #-} -- | Misc. utility functions. module Haste.Util where import DynFlags import Outputable +#if __GLASGOW_HASKELL__ >= 706 showOutputable :: Outputable a => a -> String showOutputable = showPpr tracingDynFlags-+#else+showOutputable :: Outputable a => a -> String+showOutputable = showPpr+#endif
src/Haste/Version.hs view
@@ -10,7 +10,7 @@ import Haste.Environment (hasteDir)  hasteVersion :: Version-hasteVersion = Version [0, 2, 7] []+hasteVersion = Version [0, 2, 8] []  ghcVersion :: String ghcVersion = cProjectVersion
src/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Main (main) where import GHC import GHC.Paths (libdir)@@ -69,10 +70,14 @@         then hasteMain args         else callVanillaGHC args   where+#if __GLASGOW_HASKELL__ >= 706     packageDBArgs = ["-no-global-package-db",                      "-no-user-package-db",                      "-package-db " ++ pkgDir]-+#else+    packageDBArgs = ["-no-user-package-conf",+                     "-package-conf " ++ pkgDir]+#endif -- | Call vanilla GHC; used for boot files and the like. callVanillaGHC :: [String] -> IO () callVanillaGHC args = do@@ -142,7 +147,11 @@         when (performLink cfg) $ liftIO $ do           flip mapM_ files' $ \file -> do             logStr $ "Linking " ++ outFile cfg file+#if __GLASGOW_HASKELL__ >= 706             let pkgid = showPpr dynflags $ thisPackage dynflags'+#else+            let pkgid = showPpr $ thisPackage dynflags'+#endif             link cfg pkgid file             case useGoogleClosure cfg of                Just clopath -> closurize clopath $ outFile cfg file@@ -163,7 +172,11 @@   return (pgm, name)   where     prepPgm env tidy = liftIO $ do+#if __GLASGOW_HASKELL__ >= 706       prepd <- corePrepPgm dynflags env (cg_binds tidy) (cg_tycons tidy)+#else+      prepd <- corePrepPgm dynflags (cg_binds tidy) (cg_tycons tidy)+#endif       return prepd  @@ -210,7 +223,11 @@         HsBootFile -> liftIO $ logStr $ "Skipping boot " ++ myName         _          -> do           (pgm, name) <- prepare dynflags modSummary+#if __GLASGOW_HASKELL__ >= 706           let pkgid = showPpr dynflags $ modulePackageId $ ms_mod modSummary+#else+          let pkgid = showPpr $ modulePackageId $ ms_mod modSummary+#endif               theCode = generate cfg fp pkgid name pgm           liftIO $ logStr $ "Compiling " ++ myName ++ " into " ++ targetpath           liftIO $ writeModule targetpath theCode
src/haste-copy-pkg.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | haste-copy-pkg; copy a package from file or GHC package DB and fix up its --   paths. module Main where@@ -9,7 +10,12 @@ main :: IO () main = do   args <- getArgs-  let (pkgdbs, pkgs) = partition ("--package-db=" `isPrefixOf`) args+  let (dbs, pkgs) = partition ("--package-db=" `isPrefixOf`) args+#if __GLASGOW_HASKELL__ < 706+      pkgdbs = map (("--package-conf" ++) . drop 12) dbs+#else+      pkgdbs = dbs+#endif   if null args     then do       putStrLn "Usage: haste-copy-pkg [--package-db=foo.conf] <packages>"
src/haste-pkg.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | haste-pkg; wrapper for ghc-pkg. module Main where import Control.Monad@@ -13,7 +14,12 @@     runAndWait "ghc-pkg" ["init", pkgDir] Nothing   runAndWait "ghc-pkg" (packages ++ map userToGlobal args) Nothing   where+#if __GLASGOW_HASKELL__ >= 706     packages = ["--no-user-package-db",                 "--global-package-db=" ++ pkgDir]+#else+    packages = ["--no-user-package-conf",+                "--global-conf=" ++ pkgDir]+#endif     userToGlobal "--user" = "--global"     userToGlobal str      = str