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.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, diff --git a/src/Control/Shell.hs b/src/Control/Shell.hs --- a/src/Control/Shell.hs +++ b/src/Control/Shell.hs @@ -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. diff --git a/src/Data/JSTarget/AST.hs b/src/Data/JSTarget/AST.hs --- a/src/Data/JSTarget/AST.hs +++ b/src/Data/JSTarget/AST.hs @@ -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) diff --git a/src/Data/JSTarget/PP.hs b/src/Data/JSTarget/PP.hs --- a/src/Data/JSTarget/PP.hs +++ b/src/Data/JSTarget/PP.hs @@ -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 diff --git a/src/Data/JSTarget/Print.hs b/src/Data/JSTarget/Print.hs --- a/src/Data/JSTarget/Print.hs +++ b/src/Data/JSTarget/Print.hs @@ -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 .+. ")" diff --git a/src/Haste/CodeGen.hs b/src/Haste/CodeGen.hs --- a/src/Haste/CodeGen.hs +++ b/src/Haste/CodeGen.hs @@ -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). diff --git a/src/Haste/Config.hs b/src/Haste/Config.hs --- a/src/Haste/Config.hs +++ b/src/Haste/Config.hs @@ -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 = [] } diff --git a/src/Haste/Linker.hs b/src/Haste/Linker.hs --- a/src/Haste/Linker.hs +++ b/src/Haste/Linker.hs @@ -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 diff --git a/src/Haste/PrimOps.hs b/src/Haste/PrimOps.hs --- a/src/Haste/PrimOps.hs +++ b/src/Haste/PrimOps.hs @@ -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 diff --git a/src/Haste/Util.hs b/src/Haste/Util.hs --- a/src/Haste/Util.hs +++ b/src/Haste/Util.hs @@ -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 diff --git a/src/Haste/Version.hs b/src/Haste/Version.hs --- a/src/Haste/Version.hs +++ b/src/Haste/Version.hs @@ -10,7 +10,7 @@ import Haste.Environment (hasteDir) hasteVersion :: Version -hasteVersion = Version [0, 2, 7] [] +hasteVersion = Version [0, 2, 8] [] ghcVersion :: String ghcVersion = cProjectVersion diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/haste-copy-pkg.hs b/src/haste-copy-pkg.hs --- a/src/haste-copy-pkg.hs +++ b/src/haste-copy-pkg.hs @@ -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] " diff --git a/src/haste-pkg.hs b/src/haste-pkg.hs --- a/src/haste-pkg.hs +++ b/src/haste-pkg.hs @@ -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