diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Anton Ekblad 2012-2013 +Copyright Anton Ekblad 2012-2014 All rights reserved. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,11 +1,12 @@ {-# LANGUAGE CPP #-} import Distribution.Simple import Distribution.Simple.Setup -import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.LocalBuildInfo hiding (libdir) import Distribution.PackageDescription import Control.Monad (when, forM_) import System.Directory import System.FilePath +import GHC.Paths main = defaultMainWithHooks $ simpleUserHooks { postBuild = \args buildflags pkgdesc buildinfo -> do @@ -28,23 +29,23 @@ ++ "and doesn't seem to be a Haste installation." when (dirExists && isHasteDir) $ removeDirectoryRecursive outdir - + + -- Create directory and mark as ours createDirectoryIfMissing True (outdir "js") - + createDirectoryIfMissing True (outdir "bin") + writeFile (outdir ".hastedir") "" + -- Copy executables forM_ exes $ \exe -> do exists <- doesFileExist $ builddir exe exe if exists - then copyFile (builddir exe exe) (outdir exe) + then copyFile (builddir exe exe) (outdir "bin" exe) else copyFile (builddir exe exe <.> "exe") - (outdir exe <.> "exe") + (outdir "bin" exe <.> "exe") -- Copy libs forM_ jsfiles $ \js -> do copyFile (datadir js) (outdir "js" js) - - -- Mark the directory as ours - writeFile (outdir ".hastedir") "" } has :: LocalBuildInfo -> String -> Bool 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.3 +Version: 0.4 License: BSD3 License-File: LICENSE Synopsis: Haskell To ECMAScript compiler @@ -38,12 +38,6 @@ Flag portable Description: - Install Haste and its package database into a self-contained directory. - Primarily useful for installation onto a USB stick. - Default: False - -Flag portable-compiler - Description: Install Haste into a self-contained directory. Package databases are still local to each user. Primarily useful for global installs. Default: False @@ -58,36 +52,36 @@ Haste.Version Haste.Environment Hs-Source-Dirs: src - if flag(portable-compiler) - CPP-Options: -DPORTABLE_COMPILER if flag(portable) CPP-Options: -DPORTABLE + if os(windows) + GHC-Options: -static -optl-static + else + GHC-Options: -static -optl-static -optl-pthread Build-Depends: ghc, base < 5, - directory, - process, bytestring, tar, bzlib, - zip-archive, - filepath, - temporary, - time, transformers, network, HTTP, - executable-path, - shellmate >= 0.1.5 + shellmate >= 0.1.5, + ghc-paths, + ghc, + directory Default-Language: Haskell98 Executable hastec Hs-Source-Dirs: src GHC-Options: -Wall -O2 - if flag(portable-compiler) - CPP-Options: -DPORTABLE_COMPILER if flag(portable) CPP-Options: -DPORTABLE + if os(windows) + GHC-Options: -static -optl-static + else + GHC-Options: -static -optl-static -optl-pthread Build-Depends: base < 5, ghc-prim, @@ -97,22 +91,21 @@ containers, data-default, bytestring >= 0.9.2.1, + utf8-string, blaze-builder, - filepath, - directory, array, ghc-paths, - process, random, system-fileio, - executable-path, - shellmate >= 0.1.5 + shellmate >= 0.1.5, + either, + directory Main-Is: Main.hs Other-Modules: - Args - ArgSpecs Haste + Haste.Args + Haste.Opts Haste.Version Haste.Environment Haste.Config @@ -137,46 +130,53 @@ Executable haste-inst Main-Is: haste-inst.hs Hs-Source-Dirs: src - if flag(portable-compiler) - CPP-Options: -DPORTABLE_COMPILER if flag(portable) CPP-Options: -DPORTABLE + if os(windows) + GHC-Options: -static -optl-static + else + GHC-Options: -static -optl-static -optl-pthread Build-Depends: base < 5, - filepath, - process, - directory, - executable-path + shellmate, + ghc-paths, + ghc, + directory default-language: Haskell98 Executable haste-pkg Main-Is: haste-pkg.hs Hs-Source-Dirs: src - if flag(portable-compiler) - CPP-Options: -DPORTABLE_COMPILER if flag(portable) CPP-Options: -DPORTABLE + if os(windows) + GHC-Options: -static -optl-static + else + GHC-Options: -static -optl-static -optl-pthread Build-Depends: base < 5, + shellmate, + ghc-paths, + ghc, process, - filepath, - directory, - executable-path + directory default-language: Haskell98 Executable haste-install-his Main-Is: haste-install-his.hs Hs-Source-Dirs: src - if flag(portable-compiler) - CPP-Options: -DPORTABLE_COMPILER if flag(portable) CPP-Options: -DPORTABLE + if os(windows) + GHC-Options: -static -optl-static + else + GHC-Options: -static -optl-static -optl-pthread Build-Depends: base < 5, - filepath, - directory, - process, - executable-path + shellmate, + ghc-paths, + ghc, + directory default-language: Haskell98 Executable haste-copy-pkg @@ -184,20 +184,18 @@ Other-Modules: Haste.Environment Hs-Source-Dirs: src - if flag(portable-compiler) - CPP-Options: -DPORTABLE_COMPILER if flag(portable) CPP-Options: -DPORTABLE + if os(windows) + GHC-Options: -static -optl-static + else + GHC-Options: -static -optl-static -optl-pthread Build-Depends: base < 5, - filepath, - directory, - process, - temporary, - time, - transformers, - executable-path, - shellmate >= 0.1.5 + shellmate >= 0.1.5, + ghc-paths, + ghc, + directory default-language: Haskell98 Library @@ -238,13 +236,10 @@ Haste.Binary.Put Haste.Binary.Types Build-Depends: - integer-gmp, transformers, monads-tf, - ghc-prim, containers, base < 5, - array, random, binary, data-binary-ieee754, @@ -255,7 +250,9 @@ shellmate >= 0.1.5, data-default, directory, - executable-path, filepath, - process + process, + ghc-paths, + ghc, + directory Default-Language: Haskell98 diff --git a/lib/Int64.js b/lib/Int64.js --- a/lib/Int64.js +++ b/lib/Int64.js @@ -410,9 +410,9 @@ function hs_minusInt64(x, y) {return x.subtract(y);} function hs_timesInt64(x, y) {return x.multiply(y);} function hs_negateInt64(x) {return x.negate();} -function hs_uncheckedIShiftL64(x, bits) {x.shiftLeft(bits);} -function hs_uncheckedIShiftRA64(x, bits) {x.shiftRight(bits);} -function hs_uncheckedIShiftRL64(x, bits) {x.shiftRightUnsigned(bits);} +function hs_uncheckedIShiftL64(x, bits) {return x.shiftLeft(bits);} +function hs_uncheckedIShiftRA64(x, bits) {return x.shiftRight(bits);} +function hs_uncheckedIShiftRL64(x, bits) {return x.shiftRightUnsigned(bits);} function hs_intToInt64(x) {return new Long(x, 0);} function hs_int64ToInt(x) {return x.toInt();} diff --git a/lib/rts.js b/lib/rts.js --- a/lib/rts.js +++ b/lib/rts.js @@ -32,7 +32,10 @@ // results in non-functions getting applied, so we have to deal with // it. if(!(f instanceof Function)) { - return f; + f = B(f); + if(!(f instanceof Function)) { + return f; + } } if(f.arity === undefined) { @@ -75,6 +78,16 @@ } } +/* Bounce + Bonuce on a trampoline for as long as we get a function back. +*/ +function B(f) { + while(f instanceof F) { + f = f.f(); + } + return f; +} + // Export Haste, A and E. Haste because we need to preserve exports, A and E // because they're handy for Haste.Foreign. if(!window) { @@ -281,8 +294,6 @@ return A(handler,[e, 0]); } } - -var coercionToken = undefined; /* Haste represents constructors internally using 1 for the first constructor, 2 for the second, etc. diff --git a/lib/stdlib.js b/lib/stdlib.js --- a/lib/stdlib.js +++ b/lib/stdlib.js @@ -54,8 +54,8 @@ posy = e.clientY + document.body.scrollTop + document.documentElement.scrollTop; } - return [posx - (e.target.offsetLeft || 0), - posy - (e.target.offsetTop || 0)]; + return [posx - (e.currentTarget.offsetLeft || 0), + posy - (e.currentTarget.offsetTop || 0)]; } function jsSetCB(elem, evt, cb) { @@ -192,6 +192,18 @@ return [0]; } + +function jsGetFirstChild(elem) { + var len = elem.childNodes.length; + for(var i = 0; i < len; i++) { + if(typeof elem.childNodes[i].tagName != 'undefined') { + return [1,[0,elem.childNodes[i]]]; + } + } + return [0]; +} + + function jsGetChildren(elem) { var children = [0]; var len = elem.childNodes.length; @@ -270,6 +282,8 @@ case 'object': if(obj instanceof Array) { return [3, arr2lst_json(obj, 0)]; + } else if (obj == null) { + return [5]; } else { // Object type but not array - it's a dictionary. // The RFC doesn't say anything about the ordering of keys, but @@ -315,7 +329,11 @@ function ajaxReq(method, url, async, postdata, cb) { var xhr = new XMLHttpRequest(); xhr.open(method, url, async); - xhr.setRequestHeader('Cache-control', 'no-cache'); + + if(method == "POST") { + xhr.setRequestHeader("Content-type", + "application/x-www-form-urlencoded"); + } xhr.onreadystatechange = function() { if(xhr.readyState == 4) { if(xhr.status == 200) { diff --git a/libraries/haste-lib/src/Haste/Ajax.hs b/libraries/haste-lib/src/Haste/Ajax.hs --- a/libraries/haste-lib/src/Haste/Ajax.hs +++ b/libraries/haste-lib/src/Haste/Ajax.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} -- | Low level XMLHttpRequest support. IE6 and older are not supported. module Haste.Ajax (Method (..), URL, Key, Val, textRequest, textRequest_, jsonRequest, jsonRequest_) where @@ -67,20 +69,26 @@ -- | Does the same thing as 'jsonRequest' but uses 'JSString's instead of -- Strings. -jsonRequest_ :: MonadIO m +jsonRequest_ :: MonadIO m => Method -> JSString -> [(JSString, JSString)] -> (Maybe JSON -> IO ()) -> m () jsonRequest_ m url kv cb = liftIO $ do - _ <- ajaxReq (toJSStr $ show m) url' True "" cb' - return () + _ <- ajaxReq (toJSStr $ show m) url' True pd cb' + return () where liftEither (Right x) = Just x liftEither _ = Nothing cb' = mkCallback $ \mjson -> cb (mjson >>= liftEither . decodeJSON) - url' = if null kv then url else catJSStr "?" [url, toQueryString kv] + url' = case m of + GET -> if null kv then url else catJSStr "?" [url, toQueryString kv] + POST -> url + pd = case m of + GET -> "" + POST -> if null kv then "" else toQueryString kv + toQueryString :: [(JSString, JSString)] -> JSString toQueryString = catJSStr "&" . map (\(k,v) -> catJSStr "=" [k,v]) 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 @@ -5,10 +5,12 @@ elemById, setProp, getProp, setAttr, getAttr, setProp', getProp', getValue, withElem , withElems, addChild, addChildBefore, removeChild, clearChildren , getChildBefore, - getLastChild, getChildren, setChildren , getStyle, setStyle, - getStyle', setStyle', + getFirstChild, getLastChild, getChildren, setChildren, + getStyle, setStyle, getStyle', setStyle', getFileData, getFileName, - setClass, toggleClass, hasClass + setClass, toggleClass, hasClass, + click, focus, blur, + documentBody ) where import Haste.Prim import Haste.JSType @@ -16,6 +18,7 @@ import Control.Monad.IO.Class import Haste.Foreign import Haste.Binary.Types +import System.IO.Unsafe (unsafePerformIO) newtype Elem = Elem JSAny instance Pack Elem @@ -35,6 +38,7 @@ foreign import ccall jsCreateElem :: JSString -> IO Elem foreign import ccall jsCreateTextNode :: JSString -> IO Elem foreign import ccall jsAppendChild :: Elem -> Elem -> IO () +foreign import ccall jsGetFirstChild :: Elem -> IO (Ptr (Maybe Elem)) foreign import ccall jsGetLastChild :: Elem -> IO (Ptr (Maybe Elem)) foreign import ccall jsGetChildren :: Elem -> IO (Ptr [Elem]) foreign import ccall jsSetChildren :: Elem -> Ptr [Elem] -> IO () @@ -53,6 +57,7 @@ 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!" +jsGetFirstChild = error "Tried to use jsGetFirstChild on server side!" jsGetLastChild = error "Tried to use jsGetLastChild on server side!" jsGetChildren = error "Tried to use jsGetChildren on server side!" jsSetChildren = error "Tried to use jsSetChildren on server side!" @@ -79,6 +84,10 @@ getChildBefore :: MonadIO m => Elem -> m (Maybe Elem) getChildBefore e = liftIO $ fromPtr `fmap` jsGetChildBefore e +-- | Get the first of an element's children. +getFirstChild :: MonadIO m => Elem -> m (Maybe Elem) +getFirstChild e = liftIO $ fromPtr `fmap` jsGetFirstChild e + -- | Get the last of an element's children. getLastChild :: MonadIO m => Elem -> m (Maybe Elem) getLastChild e = liftIO $ fromPtr `fmap` jsGetLastChild e @@ -228,3 +237,35 @@ {-# NOINLINE getc #-} getc :: Elem -> String -> IO Bool getc = ffi "(function(e,c) {return e.classList.contains(c);})" + +-- | Generate a click event on an element. +click :: MonadIO m => Elem -> m () +click = liftIO . click' + where + {-# NOINLINE click' #-} + click' :: Elem -> IO () + click' = ffi "(function(e) {e.click();})" + +-- | Generate a focus event on an element. +focus :: MonadIO m => Elem -> m () +focus = liftIO . focus' + where + {-# NOINLINE focus' #-} + focus' :: Elem -> IO () + focus' = ffi "(function(e) {e.focus();})" + +-- | Generate a blur event on an element. +blur :: MonadIO m => Elem -> m () +blur = liftIO . blur' + where + {-# NOINLINE blur' #-} + blur' :: Elem -> IO () + blur' = ffi "(function(e) {e.blur();})" + +-- | The DOM node corresponding to document.body. +documentBody :: Elem +documentBody = unsafePerformIO getBody + where + {-# NOINLINE getBody #-} + getBody :: IO Elem + getBody = ffi "document.body" 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 @@ -247,21 +247,44 @@ class FFI a where type T a unpackify :: T a -> a - -- | TODO: although the @export@ function, which is the only user-visible - -- interface to @packify@, is type safe, the function itself is not. - -- This should be fixed ASAP! - packify :: a -> a -instance Marshal a => FFI (IO a) where +instance Pack a => FFI (IO a) where type T (IO a) = IO Unpacked unpackify = fmap pack - packify m = fmap (unsafeCoerce . unpack) m -instance (Marshal a, FFI b) => FFI (a -> b) where +instance (Unpack a, FFI b) => FFI (a -> b) where type T (a -> b) = Unpacked -> T b unpackify f x = unpackify (f $! unpack x) - packify f x = packify (f $! pack (unsafeCoerce x)) +class IOFun a where + type X a + packify :: a -> X a + +instance Unpack a => IOFun (IO a) where + type X (IO a) = Unpacked + packify = unsafePerformIO . unpack' . toOpaque . fmap unpack + where + {-# NOINLINE unpack' #-} + unpack' :: Opaque (IO a) -> IO Unpacked + unpack' = + ffi (toJSStr $ "(function(f) {" ++ + " return (function() {" ++ + " var args=Array.prototype.slice.call(arguments,0);"++ + " args.push(0);" ++ + " return E(A(f, args));" ++ + " });" ++ + "})") + +instance (Pack a, IOFun b) => IOFun (a -> b) where + type X (a -> b) = Unpacked -> X b + packify f = \x -> packify (f $! pack x) + +instance Unpack a => Unpack (IO a) where + unpack = packify + +instance (IOFun (a -> b)) => Unpack (a -> b) where + unpack = unsafeCoerce . packify + -- | Creates a function based on the given string of Javascript code. If this -- code is not well typed or is otherwise incorrect, your program may crash -- or misbehave in mystifying ways. Haste makes a best-effort try to save you @@ -283,19 +306,9 @@ -- --opt-google-closure or any option that implies it, you will instead need -- to access your exports through Haste[\'name\'](), or Closure will mangle -- your function names. -export :: FFI a => JSString -> a -> IO () -export name f = - ffi (toJSStr $ "(function(s, f) {" ++ - " Haste[s] = function() {" ++ - " var args = Array.prototype.slice.call(arguments,0);" ++ - " args.push(0);" ++ - " return E(A(f, args));" ++ - " };" ++ - " return 0;" ++ - "})") name f' - where - f' :: Unpacked - f' = unsafeCoerce $! packify f +{-# NOINLINE export #-} +export :: Unpack a => JSString -> a -> IO () +export = ffi "(function(s,f){Haste[s] = f;})" unsafeUnpack :: a -> Unpacked unsafeUnpack x = diff --git a/libraries/haste-lib/src/Haste/JSON.hs b/libraries/haste-lib/src/Haste/JSON.hs --- a/libraries/haste-lib/src/Haste/JSON.hs +++ b/libraries/haste-lib/src/Haste/JSON.hs @@ -1,17 +1,21 @@ -{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings, PatternGuards, - FlexibleInstances, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} -- | Haste-specific JSON library. JSON is common enough that it's a good idea -- to create as fast and small an implementation as possible. To that end, -- the parser is implemented entirely in Javascript, and works with any -- browser that supports JSON.parse; IE does this from version 8 and up, and -- everyone else has done it since just about forever. module Haste.JSON (JSON (..), encodeJSON, decodeJSON, toObject, (!), (~>)) where +import Haste import Haste.Prim import Data.String as S #ifndef __HASTE__ -import Haste.Parsing import Control.Applicative import Data.Char (ord) +import Haste.Parsing import Numeric (showHex) #endif @@ -33,6 +37,7 @@ | Bool Bool | Arr [JSON] | Dict [(JSString, JSON)] + | Null instance IsString JSON where fromString = Str . S.fromString @@ -92,7 +97,7 @@ class JSONLookup a where -- | Look up a key in a JSON dictionary. Return Nothing if the key can't be -- found for some reason. - (~>) :: a -> JSString -> Maybe JSON + (~>) :: a -> JSString -> Maybe JSON infixl 5 ~> instance JSONLookup JSON where @@ -115,6 +120,8 @@ quote = "\"" true = "true" false = "false" + null = "null" + enc acc Null = null : acc enc acc (Str s) = jsStringify s : acc enc acc (Num d) = jsShowD d : acc enc acc (Bool True) = true : acc @@ -148,9 +155,11 @@ Bool <$> boolean, Str <$> jsstring, Arr <$> array, - Dict <$> object] + Dict <$> object, + null] jsstring = toJSStr <$> oneOf [quotedString '\'', quotedString '"'] boolean = oneOf [string "true" >> pure True, string "false" >> pure False] + null = string "null" >> pure Null array = do char '[' >> possibly whitespace elements <- commaSeparated json diff --git a/src/ArgSpecs.hs b/src/ArgSpecs.hs deleted file mode 100644 --- a/src/ArgSpecs.hs +++ /dev/null @@ -1,163 +0,0 @@ --- | All of hastec's command line arguments. -module ArgSpecs (argSpecs) where -import Args -import Haste.Config -import Haste.Environment -import Data.JSTarget.PP (debugPPOpts) -import Data.List (isSuffixOf) -import System.FilePath (()) - -argSpecs :: [ArgSpec Config] -argSpecs = [ - ArgSpec { optName = "debug", - updateCfg = \cfg _ -> cfg {ppOpts = debugPPOpts}, - info = "Output indented, fairly readable code, with all " ++ - "external names included in comments."}, - ArgSpec { optName = "full-unicode", - updateCfg = \cfg _ -> fullUnicode cfg, - info = "Enable full Unicode support. Will bloat your output by " - ++ " 10-150 KB depending on usage and other options."}, - ArgSpec { optName = "dont-link", - updateCfg = \cfg _ -> cfg {performLink = False}, - info = "Don't perform linking."}, - ArgSpec { optName = "libinstall", - updateCfg = \cfg _ -> cfg {targetLibPath = jsmodDir, - performLink = False}, - info = "Install all compiled modules into the user's jsmod " - ++ "library rather than linking them together into a JS" - ++ "blob."}, - ArgSpec { optName = "opt-all", - updateCfg = optAllSafe, - info = "Enable all safe optimizations. " - ++ "Equivalent to -O2 --opt-google-closure --opt-whole-program."}, - ArgSpec { optName = "opt-all-unsafe", - updateCfg = optAllUnsafe, - info = "Enable all safe and unsafe optimizations. " - ++ "Equivalent to --opt-all --opt-unsafe-ints."}, - ArgSpec { optName = "opt-google-closure", - updateCfg = updateClosureCfg, - info = "Run the Google Closure compiler on the output. " - ++ "Use --opt-google-closure=foo.jar to hint that foo.jar " - ++ "is the Closure compiler."}, - ArgSpec { optName = "opt-google-closure-flag=", - updateCfg = updateClosureFlags, - info = "Add an extra flag for the Google Closure compiler to take. " - ++ "Use --opt-google-closure-flag='--language_in=ECMASCRIPT5_STRICT', " - ++ "to optimize programs to strict mode"}, - ArgSpec { optName = "opt-sloppy-tce", - updateCfg = useSloppyTCE, - info = "Allow the possibility that some tail recursion may not " - ++ "be optimized, to get slightly smaller code."}, - ArgSpec { optName = "opt-unsafe-ints", - updateCfg = unsafeMath, - info = "Enable all unsafe Int math optimizations. Equivalent to " - ++ "--opt-unsafe-mult --opt-vague-ints"}, - ArgSpec { optName = "opt-unsafe-mult", - updateCfg = unsafeMul, - info = "Use Javascript's built-in multiplication operator for " - ++ "fixed precision integer multiplication. This speeds " - ++ "up Int multiplication by a factor of at least four, " - ++ "but may give incorrect results when the product " - ++ "falls outside the interval [-2^52, 2^52]."}, - ArgSpec { optName = "opt-vague-ints", - updateCfg = vagueInts, - info = "Int math has 53 bits of precision, but gives incorrect " - ++ "results rather than properly wrapping around when " - ++ "those 53 bits are exceeded. Bitwise operations still " - ++ "only work on the lowest 32 bits. This option should " - ++ "give a substantial performance boost for Int math " - ++ "heavy code."}, - ArgSpec { optName = "opt-whole-program", - updateCfg = enableWholeProgramOpts, - info = "Perform optimizations over the whole program at link " - ++ "time. May significantly increase compilation time."}, - ArgSpec { optName = "out=", - updateCfg = \cfg outfile -> cfg {outFile = \_ _ -> head outfile}, - info = "Write compiler output to ."}, - ArgSpec { optName = "output-html", - updateCfg = \cfg _ -> cfg {outputHTML = True}, - info = "Produce a skeleton HTML file containing the program."}, - ArgSpec { optName = "separate-namespace", - updateCfg = \cfg _ -> cfg {wrapProg = True}, - info = "Wrap the program in its own namespace? " - ++ "Off by default since it may hurt performance."}, - ArgSpec { optName = "start=", - updateCfg = \cfg str -> cfg {appStart = startCustom (head str)}, - info = "Specify how the Haste application will launch. Can be " - ++ "either asap, onload or a custom string " - ++ "containing the character sequence '%%', which will " - ++ "be replaced with the program's entry point function. " - ++ "The default is onload." - ++ " Note that '%%' will be replaced by the main function" - ++ " itself, not a call to it. Thus, in order to actually" - ++ " call the function, one would use '%%()'."}, - ArgSpec { optName = "trace-primops", - updateCfg = \cfg _ -> cfg {tracePrimops = True, - rtsLibs = debugLib : rtsLibs cfg}, - info = "Turn on run-time tracing of primops."}, - ArgSpec { optName = "verbose", - updateCfg = \cfg _ -> cfg {verbose = True}, - info = "Display even the most obnoxious warnings."}, - ArgSpec { optName = "with-js=", - updateCfg = \cfg args -> cfg {jsExternals = args}, - info = "Comma-separated list of .js files to include in the " - ++ "final JS bundle."} - ] - --- | Compose two config update functions. Be careful about using any args with --- them though! -(|||) :: (Config -> [String] -> Config) - -> (Config -> [String] -> Config) - -> (Config -> [String] -> Config) -a ||| b = \cfg args -> b (a cfg args) args - --- | Don't wrap Ints. -vagueInts :: Config -> [String] -> Config -vagueInts cfg _ = cfg {wrapIntMath = id} - --- | Use fast but unsafe multiplication. -unsafeMul :: Config -> [String] -> Config -unsafeMul cfg _ = cfg {multiplyIntOp = fastMultiply} - --- | Enable all unsafe math ops. Remember to update the info text when changing --- this! -unsafeMath :: Config -> [String] -> Config -unsafeMath = vagueInts ||| unsafeMul - --- | Enable all optimizations, both safe and unsafe. -optAllUnsafe :: Config -> [String] -> Config -optAllUnsafe = optAllSafe ||| unsafeMath ||| enableWholeProgramOpts - --- | Enable all safe optimizations. -optAllSafe :: Config -> [String] -> Config -optAllSafe = updateClosureCfg - --- | Set the path to the Closure compiler.jar to use. -updateClosureCfg :: Config -> [String] -> Config -updateClosureCfg cfg ['=':arg] = - cfg {useGoogleClosure = Just arg} -updateClosureCfg cfg _ = - cfg {useGoogleClosure = Just closureCompiler} - --- | Add flags for Google Closure to use -updateClosureFlags :: Config -> [String] -> Config -updateClosureFlags cfg args = cfg { - useGoogleClosureFlags = useGoogleClosureFlags cfg ++ args} - --- | Enable optimizations over the entire program. -enableWholeProgramOpts :: Config -> [String] -> Config -enableWholeProgramOpts cfg _ = cfg {wholeProgramOpts = True} - --- | Enable sloppy TCE; see Config for more info. -useSloppyTCE :: Config -> [String] -> Config -useSloppyTCE cfg _ = cfg {sloppyTCE = True} - --- | Save some space and performance by using degenerate implementations of --- the Unicode functions. -fullUnicode :: Config -> Config -fullUnicode cfg = - cfg {rtsLibs = unicode : filter (not . (cheap `isSuffixOf`)) libs} - where - libs = rtsLibs cfg - unicode = jsDir "unicode.js" - cheap = jsDir "cheap-unicode.js" diff --git a/src/Args.hs b/src/Args.hs deleted file mode 100644 --- a/src/Args.hs +++ /dev/null @@ -1,64 +0,0 @@ -module Args (ArgSpec (..), handleArgs) where -import Data.List (partition, stripPrefix) - -data ArgSpec a = ArgSpec { - optName :: String, - updateCfg :: a -> [String] -> a, - info :: String - } - --- | Updates a config based on the given list of ArgSpecs and command line --- arguments. If --help is encountered within the arguments, we stop --- everything and just return a help message. -handleArgs :: a -> [ArgSpec a] -> [String] -> Either String (a, [String]) -handleArgs cfg specs args = - if elem "--help" cfgargs - then Left (printHelp specs) - else Right (foldl (matchSpec specs) cfg (map (drop 2) cfgargs), rest) - where - (cfgargs, rest) = partition ((== "--") . take 2) args - -matchSpec :: [ArgSpec a] -> a -> String -> a -matchSpec specs cfg arg = - foldl updCfg cfg matchingSpecs - where - updCfg cfg' (spec, args) = - updateCfg spec cfg' (commaBreak args) - specArgs = - map (\spec -> stripPrefix (optName spec) arg) specs - matchingSpecs = - map (\(s, Just a) -> (s, a)) $ filter isMatching (zip specs specArgs) - isMatching (_, Nothing) = False - isMatching _ = True - --- | Like 'words', except it breaks on commas instead of spaces. -commaBreak :: String -> [String] -commaBreak [] = [] -commaBreak s = - case span (/= ',') s of - (w, ws) -> w : commaBreak (drop 1 ws) - -printHelp :: [ArgSpec a] -> String -printHelp = unlines . map helpString - -helpString :: ArgSpec a -> String -helpString spec = - "--" ++ hdr ++ "\n" - ++ formatHelpMessage (info spec) - where - hdr = - case last $ optName spec of - '=' -> optName spec ++ "" - _ -> optName spec - --- | Break lines at 80 chars, add two spaces before each. -formatHelpMessage :: String -> String -formatHelpMessage s = - unlines $ map (" " ++) $ breakLines 0 [] ws - where - ws = words s - breakLines len ln (w:ws) - | len+length w >= 78 = unwords (reverse ln) : breakLines 0 [] (w:ws) - | otherwise = breakLines (len+1+length w) (w:ln) ws - breakLines _ ln _ = - [unwords $ reverse ln] diff --git a/src/Data/JSTarget.hs b/src/Data/JSTarget.hs --- a/src/Data/JSTarget.hs +++ b/src/Data/JSTarget.hs @@ -1,7 +1,7 @@ -- | Javascript subset as a target language for compilers. module Data.JSTarget ( module Constr, module Op, module Optimize, module Trav, - Fingerprint, PPOpts (..), pretty, runPP, prettyProg, def, + PPOpts (..), pretty, runPP, prettyProg, def, Arity, Comment, Shared, Name (..), Var (..), LHS, Call, Lit, Exp, Stm, Alt, AST (..), Module (..), foreignModule, moduleOf, pkgOf, blackHole, blackHoleVar 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 @@ -58,9 +58,13 @@ deriving (Eq, Show) -- | Distinguish between normal, optimized and method calls. +-- Normal and optimized calls take a boolean indicating whether the called +-- function should trampoline or not. This defaults to True, and should +-- only be set to False when there is absolutely no possibility whatsoever +-- that the called function will tailcall. data Call where - Normal :: Call - Fast :: Call + Normal :: Bool -> Call + Fast :: Bool -> Call Method :: String -> Call deriving (Eq, Show) @@ -77,8 +81,6 @@ data Exp where Var :: Var -> Exp Lit :: Lit -> Exp - -- A verbatim JS expression. Must always be non-computing! - Verbatim :: String -> Exp Not :: Exp -> Exp BinOp :: BinOp -> Exp -> Exp -> Exp Fun :: Maybe Name -> [Var] -> Stm -> Exp @@ -87,32 +89,31 @@ 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 - Cont :: Stm - Jump :: Shared Stm -> Stm - NullRet :: 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 + NullRet :: Stm + Tailcall :: Exp -> Stm + ThunkRet :: Exp -> Stm -- Return from a Thunk deriving (Eq, Show) -- | Case alternatives - an expression to match and a branch. type Alt = (Exp, Stm) --- | Module fingerprint, containing a hash of compiler options and other things --- that may be used to determine whether the module needs recompiling or not. -type Fingerprint = String - --- | Represents a module. A module has a name, a fingerprint, an owning +-- | Represents a module. A module has a name, an owning -- package, a dependency map of all its definitions, and a bunch of -- definitions. data Module = Module { - modFingerprint :: !Fingerprint, modPackageId :: !String, modName :: !String, modDeps :: !(M.Map Name (S.Set Name)), @@ -122,7 +123,6 @@ -- | Imaginary module for foreign code that may need one. foreignModule :: Module foreignModule = Module { - modFingerprint = "", modPackageId = "", modName = "", modDeps = M.empty, diff --git a/src/Data/JSTarget/Binary.hs b/src/Data/JSTarget/Binary.hs --- a/src/Data/JSTarget/Binary.hs +++ b/src/Data/JSTarget/Binary.hs @@ -13,9 +13,9 @@ get = AST <$> get <*> get instance Binary Module where - put (Module fp pkgid name deps defs) = - put fp >> put pkgid >> put name >> put deps >> put defs - get = Module <$> get <*> get <*> get <*> get <*> get + put (Module pkgid name deps defs) = + put pkgid >> put name >> put deps >> put defs + get = Module <$> get <*> get <*> get <*> get instance Binary Var where put (Foreign str) = putWord8 0 >> put str @@ -31,11 +31,13 @@ get = getWord8 >>= ([NewVar <$>get<*>get, LhsExp <$> get] !!) . fromIntegral instance Binary Call where - put Normal = putWord8 0 - put Fast = putWord8 1 - put (Method m) = putWord8 2 >> put m + put (Normal tr) = putWord8 0 >> put tr + put (Fast tr) = putWord8 1 >> put tr + put (Method m) = putWord8 2 >> put m - get = getWord8 >>= ([pure Normal,pure Fast,Method <$> get] !!) . fromIntegral + get = do + tag <- fromIntegral <$> getWord8 + [Normal <$> get, Fast <$> get,Method <$> get] !! tag instance Binary Lit where put (LNum d) = putWord8 0 >> put d @@ -60,21 +62,25 @@ put (Arr exs) = putWord8 7 >> put exs put (AssignEx l r) = putWord8 8 >> put l >> put r put (IfEx c th el) = putWord8 9 >> put c >> put th >> put el + put (Eval x) = putWord8 10 >> put x + put (Thunk x) = putWord8 11 >> put x get = do tag <- getWord8 case tag of - 0 -> Var <$> get - 1 -> Lit <$> get - 2 -> Not <$> get - 3 -> BinOp <$> get <*> get <*> get - 4 -> Fun <$> get <*> get <*> get - 5 -> Call <$> get <*> get <*> get <*> get - 6 -> Index <$> get <*> get - 7 -> Arr <$> get - 8 -> AssignEx <$> get <*> get - 9 -> IfEx <$> get <*> get <*> get - n -> error $ "Bad tag in get :: Get Exp: " ++ show n + 0 -> Var <$> get + 1 -> Lit <$> get + 2 -> Not <$> get + 3 -> BinOp <$> get <*> get <*> get + 4 -> Fun <$> get <*> get <*> get + 5 -> Call <$> get <*> get <*> get <*> get + 6 -> Index <$> get <*> get + 7 -> Arr <$> get + 8 -> AssignEx <$> get <*> get + 9 -> IfEx <$> get <*> get <*> get + 10 -> Eval <$> get + 11 -> Thunk <$> get + n -> error $ "Bad tag in get :: Get Exp: " ++ show n instance Binary Stm where put (Case e def alts next) = @@ -91,6 +97,10 @@ putWord8 5 >> put j put (NullRet) = putWord8 6 + put (Tailcall ex) = + putWord8 7 >> put ex + put (ThunkRet ex) = + putWord8 8 >> put ex get = do tag <- getWord8 @@ -102,6 +112,8 @@ 4 -> pure Cont 5 -> Jump <$> get 6 -> pure NullRet + 7 -> Tailcall <$> get + 8 -> ThunkRet <$> get n -> error $ "Bad tag in get :: Get Stm: " ++ show n instance Binary BinOp where diff --git a/src/Data/JSTarget/Constructors.hs b/src/Data/JSTarget/Constructors.hs --- a/src/Data/JSTarget/Constructors.hs +++ b/src/Data/JSTarget/Constructors.hs @@ -59,28 +59,29 @@ callMethod obj meth args = Call 0 (Method meth) <$> obj <*> sequence args --- | Foreign function call. Always saturated. +-- | Foreign function call. Always saturated, never trampolines. callForeign :: String -> [AST Exp] -> AST Exp -callForeign f = fmap (Call 0 Fast (Var $ foreignVar f)) . sequence +callForeign f = fmap (Call 0 (Fast False) (Var $ foreignVar f)) . sequence -- | A normal function call. May be unsaturated. A saturated call is always -- turned into a fast call. call :: Arity -> AST Exp -> [AST Exp] -> AST Exp call arity f xs = do - foldApp <$> (Call (arity - length xs) Normal <$> f <*> sequence xs) + foldApp <$> (Call (arity - length xs) (Normal True) <$> f <*> sequence xs) callSaturated :: AST Exp -> [AST Exp] -> AST Exp -callSaturated f xs = Call 0 Fast <$> f <*> sequence xs +callSaturated f xs = Call 0 (Fast True) <$> f <*> sequence xs -- | "Fold" nested function applications into one, turning them into fast calls -- if they turn out to be saturated. foldApp :: Exp -> Exp -foldApp (Call arity Normal (Call _ Normal f args) args') = - Call arity Normal (foldApp f) (args ++ args') -foldApp (Call 0 Normal f args) = - Call 0 Fast f args -foldApp (Call arity Normal f args) | arity > 0 = - Fun Nothing newargs $ Return $ Call arity Fast f (args ++ map Var newargs) +foldApp (Call arity (Normal tramp) (Call _ (Normal _) f args) args') = + Call arity (Normal tramp) (foldApp f) (args ++ args') +foldApp (Call 0 (Normal tramp) f args) = + Call 0 (Fast tramp) f args +foldApp (Call arity (Normal tramp) f args) | arity > 0 = + Fun Nothing newargs $ Return + $ Call arity (Fast tramp) f (args ++ map Var newargs) where newargs = newVars "_fa_" arity foldApp ex = @@ -95,35 +96,16 @@ -- | Create a thunk. thunk :: AST Stm -> AST Exp -thunk stm = callForeign "new T" [Fun Nothing [] <$> stm] - --- | Unpack the given expression if it's a thunk without internal bindings. -fromThunk :: AST Exp -> Maybe (AST Exp) -fromThunk (AST (Call 0 Fast (Var (Foreign "new T")) [body]) js) = - case body of - Fun Nothing [] (Return ex) -> Just (AST ex js) - _ -> Nothing -fromThunk _ = - Nothing - --- | Returns True if the given expression causes evaluation by appearing --- outside a closure, otherwise False. -evaluates :: Exp -> Bool -evaluates (Var _) = False -evaluates (Lit _) = False -evaluates (Not ex) = evaluates ex -evaluates (BinOp _ a b) = evaluates a || evaluates b -evaluates (Fun _ _ _) = False -evaluates (Call _ _ _ _) = True -evaluates (Index a b) = evaluates a || evaluates b -evaluates (Arr xs) = any evaluates xs -evaluates (AssignEx a b) = evaluates a || evaluates b -evaluates (IfEx c a b) = evaluates c || evaluates a || evaluates b +thunk = fmap Thunk -- | Evaluate an expression that may or may not be a thunk. eval :: AST Exp -> AST Exp -eval = callForeign "E" . (:[]) +eval = fmap Eval +-- | Create a tail call. +tailcall :: AST Exp -> AST Stm +tailcall call = Tailcall <$> call + -- | A binary operator. binOp :: BinOp -> AST Exp -> AST Exp -> AST Exp binOp op a b = BinOp op <$> a <*> b @@ -161,9 +143,13 @@ alts' <- sequence [(,) <$> x <*> s jmp | (x, s) <- alts] pure $ Case ex' def' alts' (Shared shared) --- | Return from a function. Only statement that doesn't take a continuation. +-- | Return from a function. ret :: AST Exp -> AST Stm ret = fmap Return + +-- | Return from a thunk. +thunkRet :: AST Exp -> AST Stm +thunkRet = fmap ThunkRet -- | Create a new var with a new value. newVar :: Reorderable -> Var -> AST Exp -> AST Stm -> AST Stm diff --git a/src/Data/JSTarget/Optimize.hs b/src/Data/JSTarget/Optimize.hs --- a/src/Data/JSTarget/Optimize.hs +++ b/src/Data/JSTarget/Optimize.hs @@ -23,19 +23,19 @@ >>= zapJSStringConversions >>= optimizeThunks >>= optimizeArrays - >>= optUnsafeEval >>= tailLoopify f + >>= trampoline >>= ifReturnToTernary topLevelInline :: AST Stm -> AST Stm topLevelInline (AST ast js) = flip runTravM js $ do - inlineAssigns ast + unTrampoline ast + >>= inlineAssigns >>= optimizeArrays >>= optimizeThunks >>= optimizeArrays >>= zapJSStringConversions - >>= optUnsafeEval -- | Attempt to turn two case branches into a ternary operator expression. tryTernary :: Var @@ -172,11 +172,9 @@ Call _ _ (Var (Foreign "unCStr")) [x]]) = return x opt (Call _ _ (Var (Foreign "toJSStr")) [ - Call _ _ (Var (Foreign "E")) [ - Call _ _ (Var (Foreign "unCStr")) [x]]]) = + Eval (Call _ _ (Var (Foreign "unCStr")) [x])]) = return x - opt (Call _ _ (Var (Foreign "new T")) - [Fun _ [] (Return x@(Call _ _ (Var (Foreign "unCStr")) [Lit _]))]) = + opt (Thunk (Return x@(Call _ _ (Var (Foreign "unCStr")) [Lit _]))) = return x opt x = return x @@ -197,7 +195,7 @@ optimizeThunks ast = mapJS (const True) optEx return ast where - optEx (Call _ _ (Var (Foreign "E")) [x]) + optEx (Eval x) | Just x' <- fromThunkEx x = return x' | Fun _ _ _ <- x = return x optEx (Call arity calltype f args) | Just f' <- fromThunkEx f = @@ -209,12 +207,8 @@ -- | Unpack the given expression if it's a thunk. fromThunk :: Exp -> Maybe Stm -fromThunk (Call _ Fast (Var (Foreign "new T")) [body]) = - case body of - Fun Nothing [] (b) -> Just b - _ -> Nothing -fromThunk _ = - Nothing +fromThunk (Thunk body) = Just body +fromThunk _ = Nothing -- | Unpack the given expression if it's a thunk without internal bindings. fromThunkEx :: Exp -> Maybe Exp @@ -237,32 +231,15 @@ computingEx :: Exp -> Bool computingEx ex = case ex of - Var _ -> False - Lit _ -> False - Verbatim _ -> False - Fun _ _ _ -> False - Arr arr -> any computingEx arr - e | Just t <- fromThunk e -> False - | otherwise -> True - --- | When possible, optimize ffi "x" into x. -optUnsafeEval :: JSTrav ast => ast -> TravM ast -optUnsafeEval = mapJS (const True) opt return - where - opt ex = - case ex of - (Call ar c (Var (Internal - (Name "unsafeEval" (Just (pkg, "Haste.Foreign"))) _)) - (Arr [Lit (LNum 0), Lit (LStr s)] : args)) - | take 9 pkg == "haste-lib" -> do - case args of - [] -> return $ Verbatim s - _ -> return $ Call (ar-1) c (Verbatim s) args - _ -> do - return ex + Var _ -> False + Lit _ -> False + Fun _ _ _ -> False + Thunk _ -> False + Arr arr -> any computingEx arr + _ -> True --- | Gather a map of all inlinable symbols; that is, the once that are used +-- | Gather a map of all inlinable symbols; that is, the ones that are used -- exactly once. -- TODO: always inline assigns that are just aliases! gatherInlinable :: JSTrav ast => ast -> TravM (M.Map Var Occs) @@ -281,6 +258,83 @@ countOccs m _ = pure m +-- | May the given expression ever tailcall? +mayTailcall :: JSTrav ast => ast -> TravM Bool +mayTailcall ast = do + foldJS enter countTCs False ast + where + enter True _ = False + enter _ (Exp (Thunk _)) = False + enter _ (Exp (Fun _ _ _)) = False + enter _ _ = True + countTCs _ (Stm (Tailcall _)) = return True + countTCs acc _ = return acc + +-- | Gather a map of all symbols which we know will never make tail calls. +-- All calls to functions in this set can then safely be de-trampolined. +gatherNonTailcalling :: Stm -> TravM (S.Set Var) +gatherNonTailcalling stm = do + foldJS (\_ _ -> True) countTCs S.empty stm + where + countTCs s (Exp (Var v@(Foreign _))) = do + return $ S.insert v s + countTCs s (Stm (Assign (NewVar _ v) (Fun _ _ body) _)) = do + tc <- mayTailcall body + return $ if not tc then S.insert v s else s + countTCs s (Exp (Fun (Just name) _ body)) = do + tc <- mayTailcall body + return $ if not tc then S.insert (Internal name "") s else s + countTCs s _ = do + return s + +-- | Remove trampolines wherever possible. +-- The trampoline machinery has some overhead; two extra activation records +-- on the stack for a single, non-tailcalling function, to be precise. +-- We observe that bouncing a function that is guaranteed to never tailcall +-- is a waste of resources, so we can remove those bounces. +-- Additionally, tailcalling a function which is guaranteed to not tailcall +-- in turn is wasteful (see above comment about overhead), so we can +-- eliminate any such function. +-- Since the tailcalling machinery grows the stack by a total of three +-- activation records for an arbitrary string of tailcalling functions, +-- we can apply this procedure recursively three times and still be +-- guaranteed to use no more stack frames than we would have without this +-- optimization. +unTrampoline :: Stm -> TravM Stm +unTrampoline s = go s >>= go >>= go + where + go s = do + ntcs <- gatherNonTailcalling s + mapJS (const True) (unTr ntcs) (unTC ntcs) s + + unTr ntcs (Call ar (Normal True) f@(Var v) xs) + | v `S.member` ntcs = + return $ Call ar (Normal False) f xs + unTr ntcs (Call ar (Fast True) f@(Var v) xs) + | v `S.member` ntcs = + return $ Call ar (Fast False) f xs + unTr _ c@(Call ar (Normal True) f@(Fun _ _ body) xs) = do + tc <- mayTailcall body + return $ if tc then c else Call ar (Normal False) f xs + unTr _ c@(Call ar (Fast True) f@(Fun _ _ body) xs) = do + tc <- mayTailcall body + return $ if tc then c else Call ar (Fast False) f xs + unTr _ x = + return x + + -- If we know for certain that the function we're tailcalling will not + -- tailcall in turn we should not tailcall it, since that would mean two + -- activation records on the stack - one for the trampoline and one for + -- the function itself. + unTC ntcs (Tailcall c@(Call _ _ (Var v) _)) + | v `S.member` ntcs = + return $ Return c + unTC _ tc@(Tailcall c@(Call _ _ (Fun _ _ body) _)) = do + maytc <- mayTailcall body + if not maytc then return (Return c) else return tc + unTC _ x = + return x + -- | Like `inlineAssigns`, but doesn't care what happens beyond a jump. inlineAssignsLocal :: JSTrav ast => ast -> TravM ast inlineAssignsLocal ast = do @@ -348,6 +402,23 @@ | otherwise = inlineShared lbl def shrink stm = return stm +-- | Turn any calls in tail position into tailcalls. +-- Must run after @tailLoopify@ or we won't get loops for simple tail +-- recursive functions. +trampoline :: Exp -> TravM Exp +trampoline = mapJS (pure True) pure bounce + where + bounce (Return (Call arity call f args)) = do + return $ Tailcall $ Call arity call' f args + where + call' = + case call of + Normal _ -> Normal False + Fast _ -> Fast False + c -> c + bounce s = do + return s + -- | Turn tail recursion on the given var into a loop, if possible. -- Tail recursive functions that create closures turn into: -- function f(a', b', c') { @@ -376,7 +447,8 @@ nv = NewVar False nn body' = Forever $ - Assign nv (Call 0 Fast (Fun Nothing args b) (map Var args'))$ + Assign nv (Call 0 (Fast False) (Fun Nothing args b) + (map Var args')) $ Case (Var nn) (Return (Var nn)) [(Lit $ LNull, NullRet)] $ (Shared nullRetLbl) putRef nullRetLbl NullRet @@ -394,6 +466,7 @@ -- Only traverse until we find a closure createsClosures = foldJS (\acc _ -> not acc) isClosure False isClosure _ (Exp (Fun _ _ _)) = pure True + isClosure _ (Exp (Thunk _)) = pure True isClosure acc _ = pure acc -- Assign any changed vars, then loop. @@ -428,6 +501,7 @@ contains (Arr xs) var = any (`contains` var) xs contains (AssignEx l r) var = l `contains` var || r `contains` var contains (IfEx c t e) var = any (`contains` var) [c,t,e] - contains (Verbatim _) _ = False + contains (Eval x) var = x `contains` var + contains (Thunk _) _ = False tailLoopify _ fun = do return fun 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 @@ -37,8 +37,13 @@ emptyNS :: NameSupply emptyNS = (FinalName 0, M.empty) +intDec :: Int -> Builder intDec = B.fromString . show + +doubleDec :: Double -> Builder doubleDec = B.fromString . show + +integerDec :: Integer -> Builder integerDec = B.fromString . show newtype PP a = PP {unPP :: PPOpts 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 @@ -70,8 +70,6 @@ pp v pp (Lit l) = pp l - pp (Verbatim s) = - put s pp (Not ex) = case neg ex of Just ex' -> pp ex' @@ -90,10 +88,14 @@ lambdaname = maybe "" (\n -> " " .+. pp n) mname pp (Call _ call f args) = do case call of - Normal -> "A(" .+. pp f .+. ",[" .+. ppList sep args .+. "])" - Fast -> ppCallFun f .+. "(" .+. ppList sep args .+. ")" - Method m -> pp f .+. put ('.':m) .+. "(" .+. ppList sep args .+. ")" + Normal True -> "B(" .+. normalCall .+. ")" + Normal False -> normalCall + Fast True -> "B(" .+. fastCall .+. ")" + Fast False -> fastCall + Method m -> pp f .+. put ('.':m) .+. "(" .+. ppList sep args .+. ")" where + normalCall = "A(" .+. pp f .+. ",[" .+. ppList sep args .+. "])" + fastCall = ppCallFun f .+. "(" .+. ppList sep args .+. ")" ppCallFun fun@(Fun _ _ _) = "(" .+. pp fun .+. ")" ppCallFun fun = pp fun pp (Index arr ix) = do @@ -104,6 +106,10 @@ pp l .+. sp .+. "=" .+. sp .+. pp r pp (IfEx c th el) = do pp c .+. sp .+. "?" .+. sp .+. pp th .+. sp .+. ":" .+. sp .+. pp el + pp (Eval x) = do + "E(" .+. pp x .+. ")" + pp (Thunk x) = do + "new T(function(){" .+. newl .+. indent (pp x) .+. "})" instance Pretty (Var, Exp) where pp (v, ex) = pp v .+. sp .+. "=" .+. sp .+. pp ex @@ -153,6 +159,10 @@ return () pp (NullRet) = do return () + pp (Tailcall call) = do + line $ "return new F(function(){return " .+. pp call .+. ";});" + pp (ThunkRet ex) = do + line $ "return " .+. pp ex .+. ";" neg :: Exp -> Maybe Exp neg (BinOp Eq a b) = Just $ BinOp Neq a b diff --git a/src/Data/JSTarget/Traversal.hs b/src/Data/JSTarget/Traversal.hs --- a/src/Data/JSTarget/Traversal.hs +++ b/src/Data/JSTarget/Traversal.hs @@ -81,8 +81,6 @@ pure (acc, v) l@(Lit _) -> do pure (acc, l) - v@(Verbatim _) -> do - pure (acc, v) Not ex -> do fmap Not <$> mapEx acc ex BinOp op a b -> do @@ -110,6 +108,10 @@ (acc'', th') <- mapEx acc' th (acc''', el') <- mapEx acc'' el return (acc''', IfEx c' th' el') + Eval x -> do + fmap Eval <$> mapEx acc x + Thunk x -> do + fmap Thunk <$> foldMapJS tr fe fs acc x else do return (acc, ast) fe acc' x @@ -125,8 +127,6 @@ return acc Lit _ -> do return acc - Verbatim _ -> do - return acc Not ex -> do foldJS tr f acc ex BinOp _ a b -> do @@ -149,6 +149,10 @@ acc' <- foldJS tr f acc c acc'' <- foldJS tr f acc' th foldJS tr f acc'' el + Eval ex -> do + foldJS tr f acc ex + Thunk stm -> do + foldJS tr f acc stm else do return acc f acc' expast @@ -179,6 +183,10 @@ fmap Jump <$> foldMapJS tr fe fs acc stm NullRet -> do return (acc, NullRet) + Tailcall ex -> do + fmap Tailcall <$> foldMapJS tr fe fs acc ex + ThunkRet ex -> do + fmap ThunkRet <$> foldMapJS tr fe fs acc ex else do return (acc, ast) fs acc' x @@ -207,6 +215,10 @@ foldJS tr f acc j NullRet -> do return acc + Tailcall ex -> do + foldJS tr f acc ex + ThunkRet ex -> do + foldJS tr f acc ex else do return acc f acc' stmast @@ -277,8 +289,10 @@ isShared (Label _) = True isShared _ = False +-- | Thunks and explicit lambdas count as lambda abstractions. isLambda :: ASTNode -> Bool isLambda (Exp (Fun _ _ _)) = True +isLambda (Exp (Thunk _)) = True isLambda _ = False isJump :: ASTNode -> Bool diff --git a/src/Haste.hs b/src/Haste.hs --- a/src/Haste.hs +++ b/src/Haste.hs @@ -1,8 +1,8 @@ module Haste ( module Linker, module Config, module CodeGen, - Fingerprint, Module, writeModule, readModule, readModuleFingerprint) where + Module, writeModule, readModule) where import Haste.Linker as Linker import Haste.Config as Config import Haste.Module import Haste.CodeGen as CodeGen -import Data.JSTarget.AST (Fingerprint, Module) +import Data.JSTarget.AST (Module) diff --git a/src/Haste/Args.hs b/src/Haste/Args.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Args.hs @@ -0,0 +1,95 @@ +module Haste.Args (parseArgs) where +import System.Console.GetOpt +import Data.List + +-- | Parse a list of command line arguments into a config and a list of args +-- for GHC. Non-options are passed directly to GHC. +parseArgs :: [OptDescr (a -> a)] + -> String + -> [String] + -> Either String (a -> a, [String]) +parseArgs opts hdr args + | "--help" `elem` args || "-?" `elem` args = + Left $ printHelp hdr opts + | otherwise = + let (hasteArgs, ghcArgs) = splitOpts opts args + (cfgs, _, _) = getOpt Permute opts hasteArgs + in Right (foldl' (flip (.)) id cfgs, ghcArgs) + +-- | Split opts into Haste options and others. +splitOpts :: [OptDescr a] -> [String] -> ([String], [String]) +splitOpts opts args = + (hasteArgs ++ outopts, filter (\x -> take 2 x /= "--") others) + where + (hasteArgs, others) = + partition isHasteOpt nonouts + + (outopts, nonouts) = + findOutputs ([], [], []) args + + -- TODO: this is a horrible hack to generally mangle arguments until + -- stuff works - replace ASAP with less hacky solution! + findOutputs (outs, nouts, fin) ("--libinstall" : xs) = + findOutputs (outs, nouts, "--libinstall" : fin) xs + findOutputs (outs, nouts, fin) ("-o" : out : xs) = + findOutputs (("--out=" ++ out) : outs, nouts, fin) xs + findOutputs (outs, nouts, fin) ("-outputdir" : out : xs) = + findOutputs (("--outdir=" ++ out) : outs, nouts, fin) xs + findOutputs (outs, nouts, fin) (x@('-':'o':out) : xs) + | out == "hi" = findOutputs (outs, x:nouts, fin) xs + | out == "suf" = findOutputs (outs, x:nouts, fin) xs + | out == "dir" = findOutputs (outs, x:nouts, fin) xs + | take 2 out == "pt" = findOutputs (outs, x:nouts, fin) xs + | otherwise = findOutputs (("--out="++out):outs,nouts,fin) xs + findOutputs (outs, nouts, fin) (x:xs) = + findOutputs (outs, x : nouts, fin) xs + findOutputs (outs, nouts, fin) _ = + (reverse outs ++ reverse fin, reverse nouts) + + isHasteOpt opt + | "-o" `isPrefixOf` opt = False + | otherwise = prefixElem opt optnames + + optnames = + concatMap names opts + + names (Option short long _ _) = + map (\c -> ['-',c]) short ++ map ("--" ++) long + +-- | Does the given list exist as a prefix of some element in the list of +-- lists? +prefixElem :: Eq a => [a] -> [[a]] -> Bool +prefixElem x = or . map (\y -> take (length y) x == y) + +printHelp :: String -> [OptDescr a] -> String +printHelp hdr = (hdr ++) . ("\n" ++) . unlines . map helpString + +helpString :: OptDescr a -> String +helpString (Option short long opt help) = + shorts ++ longs ++ "\n" ++ formatHelpMessage 80 help + where + (longarg, shortarg) = + case opt of + NoArg _ -> ("", "") + ReqArg _ a -> ('=':a, ' ':a) + OptArg _ a -> ("[=" ++ a ++ "]", " [" ++ a ++ "]") + shorts = + case intercalate ", " (map (\c -> ['-',c]) short) of + s | null s -> "" + | otherwise -> s ++ shortarg ++ ", " + longs = + case intercalate ", " (map (\s -> "--" ++ s) long) of + l | null l -> "" + | otherwise -> l ++ longarg + +-- | Break lines at n chars, add two spaces before each. +formatHelpMessage :: Int -> String -> String +formatHelpMessage chars help = + unlines . map (" " ++) . breakLines 0 [] $ words help + where + breakLines len ln (w:ws) + | length w >= chars-2 = w:unwords (reverse ln):breakLines 0 [] ws + | len+length w >= chars-2 = unwords (reverse ln):breakLines 0 [] (w:ws) + | otherwise = breakLines (len+1+length w) (w:ln) ws + breakLines _ ln _ = + [unwords $ reverse ln] diff --git a/src/Haste/Builtins.hs b/src/Haste/Builtins.hs --- a/src/Haste/Builtins.hs +++ b/src/Haste/Builtins.hs @@ -4,12 +4,19 @@ import Data.JSTarget as J import Control.Applicative +-- TODO: proxy# (and probably void#, realWorld# and coercionToken# as well) +-- should really just go away in the final code. + toBuiltin :: P.Var -> Maybe J.Var toBuiltin v = case (modname, varname) of (Just "GHC.Prim", "coercionToken#") -> - Just $ foreignVar "coercionToken" + Just $ foreignVar "_" (Just "GHC.Prim", "realWorld#") -> + Just $ foreignVar "_" + (Just "GHC.Prim", "void#") -> + Just $ foreignVar "_" + (Just "GHC.Prim", "proxy#") -> Just $ foreignVar "_" (Just "GHC.Err", "error") -> Just $ foreignVar "err" diff --git a/src/Haste/CodeGen.hs b/src/Haste/CodeGen.hs --- a/src/Haste/CodeGen.hs +++ b/src/Haste/CodeGen.hs @@ -10,7 +10,7 @@ import Data.List (partition, foldl') import Data.Maybe (isJust) #if __GLASGOW_HASKELL__ >= 707 -import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.UTF8 as B #endif import qualified Data.Set as S import qualified Data.Map as M @@ -43,14 +43,12 @@ import Haste.Builtins generate :: Config - -> Fingerprint -> String -> ModuleName -> [StgBinding] -> J.Module -generate cfg fp pkgid modname binds = +generate cfg pkgid modname binds = Module { - modFingerprint = fp, modPackageId = pkgid, modName = moduleNameString modname, modDeps = foldl' insDep M.empty theMod, @@ -206,7 +204,8 @@ addLocal v' expr <- genRhs (isJust funsInRecGroup) rhs popBind - let expr' = optimizeFun v' expr + opt <- optimize `fmap` getCfg + let expr' = if opt then optimizeFun v' expr else expr continue $ newVar True v' expr' genBind _ _ (StgRec _) = error $ "genBind got recursive bindings!" @@ -224,8 +223,8 @@ (retExp, body') <- isolate $ do mapM_ addLocal args' genEx body - return $ if isUpdatable upd && null args - then thunk' (body' $ ret retExp) + return $ if null args + then thunk' (body' $ thunkRet retExp) else fun args' (body' $ ret retExp) where thunk' (AST (Return l@(Lit _)) js) = AST l js @@ -259,9 +258,11 @@ -- sole alternative. case (isUnaryUnboxedTuple scrut, alts) of (True, [(_, as, _, expr)]) | [arg] <- filter hasRepresentation as -> do + scrut' <- genVar scrut arg' <- genVar arg - addLocal [arg'] - continue (newVar (reorderableType scrut) arg' ex') + addLocal [scrut', arg'] + continue (newVar (reorderableType scrut) scrut' ex') + continue (newVar (reorderableType scrut) arg' (varExp scrut')) genEx expr (True, _) -> do error "Case on unary unboxed tuple with more than one alt! WTF?!" @@ -462,7 +463,7 @@ genLit l = do case l of #if __GLASGOW_HASKELL__ >= 707 - MachStr s -> return . lit $ B.unpack s + MachStr s -> return . lit $ B.toString s #else MachStr s -> return . lit $ unpackFS s #endif diff --git a/src/Haste/Config.hs b/src/Haste/Config.hs --- a/src/Haste/Config.hs +++ b/src/Haste/Config.hs @@ -1,14 +1,16 @@ {-# LANGUAGE OverloadedStrings, Rank2Types #-} module Haste.Config ( - Config (..), AppStart, defConfig, stdJSLibs, startCustom, fastMultiply, + Config (..), AppStart, def, stdJSLibs, startCustom, fastMultiply, safeMultiply, debugLib) where import Data.JSTarget -import System.FilePath (replaceExtension, ()) +import Control.Shell (replaceExtension, ()) import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char.Utf8 import Data.Monoid import Haste.Environment import Outputable (Outputable) +import Data.Default +import Data.List (isPrefixOf, nub) type AppStart = Builder -> Builder @@ -34,13 +36,17 @@ startCustom :: String -> AppStart startCustom "onload" = startOnLoadComplete startCustom "asap" = startASAP +startCustom "onexec" = startASAP startCustom str = insertSym str --- | Replace the first occurrence of %% with Haste's entry point symbol. +-- | Replace the first occurrence of $HASTE_MAIN with Haste's entry point +-- symbol. insertSym :: String -> AppStart -insertSym ('%':'%':str) sym = sym <> fromString str -insertSym (c:str) sym = fromChar c <> insertSym str sym -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 -- | Execute the program when the document has finished loading. startOnLoadComplete :: AppStart @@ -64,7 +70,7 @@ -- | Runtime files to dump into the JS blob. rtsLibs :: [FilePath], -- | Path to directory where system jsmods are located. - libPath :: FilePath, + libPaths :: [FilePath], -- | Write all jsmods to this path. targetLibPath :: FilePath, -- | A function that takes the main symbol as its input and outputs the @@ -103,14 +109,20 @@ outputHTML :: Bool, -- | GHC DynFlags used for STG generation. -- Currently only used for printing StgSyn values. - showOutputable :: forall a. Outputable a => a -> String + showOutputable :: forall a. Outputable a => a -> String, + -- | Which module contains the program's main function? + -- Defaults to Just ("main", "Main") + mainMod :: Maybe (String, String), + -- | Perform optimizations. + -- Defaults to True. + optimize :: Bool } -- | Default compiler configuration. defConfig :: Config defConfig = Config { rtsLibs = stdJSLibs, - libPath = jsmodDir, + libPaths = nub [jsmodUserDir, jsmodSysDir], targetLibPath = ".", appStart = startOnLoadComplete, wrapProg = False, @@ -130,5 +142,10 @@ useGoogleClosureFlags = [], jsExternals = [], outputHTML = False, - showOutputable = const "No showOutputable defined in config!" + showOutputable = const "No showOutputable defined in config!", + mainMod = Just ("main", "Main"), + optimize = True } + +instance Default Config where + def = defConfig diff --git a/src/Haste/Environment.hs b/src/Haste/Environment.hs --- a/src/Haste/Environment.hs +++ b/src/Haste/Environment.hs @@ -1,30 +1,55 @@ {-# LANGUAGE CPP #-} -- | Paths, host bitness and other environmental information about Haste. -module Haste.Environment (hasteDir, jsmodDir, hasteInstDir, pkgDir, pkgLibDir, - jsDir, hostWordSize, runAndWait, hasteBinary, - hastePkgBinary, hasteInstHisBinary, hasteInstBinary, - hasteCopyPkgBinary, closureCompiler) where -import System.Process +module Haste.Environment ( + hasteSysDir, jsmodSysDir, hasteInstSysDir, pkgSysDir, pkgSysLibDir, jsDir, + hasteUserDir, jsmodUserDir, hasteInstUserDir, pkgUserDir, pkgUserLibDir, + hostWordSize, ghcLibDir, + ghcBinary, ghcPkgBinary, + hasteBinary, hastePkgBinary, hasteInstHisBinary, hasteInstBinary, + hasteCopyPkgBinary, closureCompiler, portableHaste) where import System.IO.Unsafe -import System.FilePath -import Data.Bits (bitSize) +import Data.Bits import Foreign.C.Types (CIntPtr) -import System.Environment.Executable -import System.Directory -import System.Exit +import Control.Shell +import System.Environment (getExecutablePath) +import System.Directory (findExecutable) import Paths_haste_compiler +import GHC.Paths (libdir) +import Config (cProjectVersion) +import Data.Maybe (catMaybes) --- | The directory where the currently residing binary lives. -currentBinDir :: FilePath -currentBinDir = dropFileName . unsafePerformIO $ getExecutablePath +#if defined(PORTABLE) +portableHaste :: Bool +portableHaste = True -#if defined(PORTABLE) || defined(PORTABLE_COMPILER) +-- | Haste system directory. Identical to @hasteUserDir@ unless built with +-- -f portable. +hasteSysDir :: FilePath +hasteSysDir = + joinPath . init . init . splitPath $ unsafePerformIO getExecutablePath + +ghcLibDir :: FilePath +ghcLibDir = unsafePerformIO $ do + Right out <- shell $ run ghcBinary ["--print-libdir"] "" + return $ init out + hasteBinDir :: FilePath -hasteBinDir = currentBinDir +hasteBinDir = hasteSysDir "bin" jsDir :: FilePath -jsDir = hasteBinDir "js" +jsDir = hasteSysDir "js" #else +portableHaste :: Bool +portableHaste = False + +-- | Haste system directory. Identical to @hasteUserDir@ unless built with +-- -f portable. +hasteSysDir :: FilePath +hasteSysDir = hasteUserDir + +ghcLibDir :: FilePath +ghcLibDir = libdir + hasteBinDir :: FilePath hasteBinDir = unsafePerformIO $ getBinDir @@ -32,62 +57,71 @@ jsDir = unsafePerformIO $ getDataDir #endif -#if defined(PORTABLE) -hasteDir :: FilePath -hasteDir = hasteBinDir -#else -hasteDir :: FilePath -hasteDir = unsafePerformIO $ getAppUserDataDirectory "haste" -#endif +-- | Haste user directory. Usually ~/.haste. +hasteUserDir :: FilePath +Right hasteUserDir = unsafePerformIO . shell $ withAppDirectory "haste" return -jsmodDir :: FilePath -jsmodDir = hasteDir "jsmods" +-- | Directory where user .jsmod files are stored. +jsmodSysDir :: FilePath +jsmodSysDir = hasteSysDir "jsmods" +-- | Base directory for haste-inst; system packages. +hasteInstSysDir :: FilePath +hasteInstSysDir = hasteSysDir "libraries" + +-- | Base directory for Haste's system libraries. +pkgSysLibDir :: FilePath +pkgSysLibDir = hasteInstSysDir "lib" + +-- | Directory housing package information. +pkgSysDir :: FilePath +pkgSysDir = hasteSysDir "packages" + +-- | Directory where user .jsmod files are stored. +jsmodUserDir :: FilePath +jsmodUserDir = hasteUserDir "jsmods" + -- | Base directory for haste-inst. -hasteInstDir :: FilePath -hasteInstDir = hasteDir "libraries" +hasteInstUserDir :: FilePath +hasteInstUserDir = hasteUserDir "libraries" +-- | Directory containing library information. +pkgUserLibDir :: FilePath +pkgUserLibDir = hasteInstUserDir "lib" + -- | Directory housing package information. -pkgDir :: FilePath -pkgDir = hasteDir "packages" +pkgUserDir :: FilePath +pkgUserDir = hasteUserDir "packages" -- | Host word size in bits. hostWordSize :: Int +#if __GLASGOW_HASKELL__ >= 708 +hostWordSize = finiteBitSize (undefined :: CIntPtr) +#else hostWordSize = bitSize (undefined :: CIntPtr) - --- | Directory containing library information. -pkgLibDir :: FilePath -pkgLibDir = hasteInstDir "lib" - --- | Run a process and wait for its completion. Terminate with an error code --- if the process did not exit cleanly. -runAndWait :: FilePath -> [String] -> Maybe FilePath -> IO () -runAndWait file args workDir = do - h <- runProcess file args workDir Nothing Nothing Nothing Nothing - ec <- waitForProcess h - case ec of - ExitFailure _ -> exitFailure - _ -> return () +#endif -{- --- | Find an executable. -locateBinary :: String -> [FilePath] -> IO (Either String FilePath) -locateBinary progname (c:cs) = do - mexe <- findExecutable c - case mexe of - Nothing -> locateBinary progname cs - Just exe -> return (Right exe) -locateBinary progname _ = do - return $ Left $ "No " ++ progname ++ " executable found; aborting!" +-- | Path to the GHC binary. +ghcBinary :: FilePath +ghcBinary = unsafePerformIO $ do + exes <- catMaybes `fmap` mapM findExecutable ["ghc-" ++ cProjectVersion, + "ghc"] + case exes of + (exe:_) -> return exe + _ -> error $ "No appropriate GHC executable in search path!\n" + ++ "Are you sure you have GHC " ++ cProjectVersion + ++ " installed?" --- | Find a binary. -binaryPath :: FilePath -> FilePath -binaryPath exe = unsafePerformIO $ do - b <- locateBinary exe [exe, currentBinDir exe, cabalBinDir exe] - case b of - Left err -> error err - Right path -> return path --} +-- | Path to the GHC binary. +ghcPkgBinary :: FilePath +ghcPkgBinary = unsafePerformIO $ do + exes <- catMaybes `fmap` mapM findExecutable ["ghc-pkg-" ++ cProjectVersion, + "ghc-pkg"] + case exes of + (exe:_) -> return exe + _ -> error $ "No appropriate ghc-pkg executable in search path!\n" + ++ "Are you sure you have GHC " ++ cProjectVersion + ++ " installed?" -- | The main Haste compiler binary. hasteBinary :: FilePath @@ -111,4 +145,4 @@ -- | JAR for Closure compiler. closureCompiler :: FilePath -closureCompiler = hasteDir "compiler.jar" +closureCompiler = hasteBinDir "compiler.jar" diff --git a/src/Haste/Linker.hs b/src/Haste/Linker.hs --- a/src/Haste/Linker.hs +++ b/src/Haste/Linker.hs @@ -5,26 +5,31 @@ import qualified Data.Map as M import qualified Data.Set as S import Control.Monad.State.Strict +import Control.Monad.Trans.Either import Control.Applicative import Data.JSTarget import qualified Data.ByteString.Lazy as B import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char.Utf8 import Data.Monoid +import System.IO (hPutStrLn, stderr) -- | The program entry point. -- This will need to change when we start supporting building "binaries" -- using cabal, since we'll have all sorts of funny package names then. mainSym :: Name -mainSym = name "main" (Just ("main", "Main")) +mainSym = name "main" (Just ("main", ":Main")) -- | Link a program using the given config and input file name. link :: Config -> String -> FilePath -> IO () link cfg pkgid target = do - ds <- getAllDefs (libPath cfg) pkgid mainSym + let mainmod = case mainMod cfg of + Just mm -> mm + _ -> error "Haste.Linker.link called without main sym!" + ds <- getAllDefs cfg (targetLibPath cfg : libPaths cfg) mainmod pkgid mainSym let myDefs = if wholeProgramOpts cfg then topLevelInline ds else ds - let (progText, mainSym') = prettyProg (ppOpts cfg) mainSym myDefs - callMain = fromString "A(" <> mainSym' <> fromString ", [0]);" + (progText, myMain') = prettyProg (ppOpts cfg) mainSym myDefs + callMain = fromString "B(A(" <> myMain' <> fromString ", [0]));" launchApp = appStart cfg (fromString "hasteMain") rtslibs <- mapM readFile $ rtsLibs cfg @@ -49,80 +54,123 @@ <> fromString "};" <> launchApp +-- | Produce an info message if verbose reporting is enabled. +info' :: Config -> String -> IO () +info' cfg = when (verbose cfg) . hPutStrLn stderr -- | Generate a sequence of all assignments needed to run Main.main. -getAllDefs :: FilePath -> String -> Name -> IO (AST Stm) -getAllDefs libpath pkgid mainsym = - runDep $ addDef libpath pkgid mainsym +getAllDefs :: Config + -> [FilePath] + -> (String, String) + -> String + -> Name + -> IO (AST Stm) +getAllDefs cfg libpaths mainmod pkgid mainsym = + runDep cfg mainmod $ addDef libpaths pkgid mainsym data DepState = DepState { + mainmod :: !(String, String), defs :: !(AST Stm -> AST Stm), alreadySeen :: !(S.Set Name), - modules :: !(M.Map String Module) + modules :: !(M.Map String Module), + infoLogger :: String -> IO () } -newtype DepM a = DepM (StateT DepState IO a) - deriving (Monad, MonadIO) +type DepM a = EitherT Name (StateT DepState IO) a -initState :: DepState -initState = DepState { +initState :: Config -> (String, String) -> DepState +initState cfg m = DepState { + mainmod = m, defs = id, alreadySeen = S.empty, - modules = M.empty + modules = M.empty, + infoLogger = info' cfg } --- | Run a dependency resolution computation. -runDep :: DepM a -> IO (AST Stm) -runDep (DepM m) = do - defs' <- defs . snd <$> runStateT m initState - return (defs' nullRet) +-- | Log a message to stdout if verbose reporting is on. +info :: String -> DepM () +info s = do + st <- get + liftIO $ infoLogger st s -instance MonadState DepState DepM where - get = DepM $ get - put = DepM . put +-- | Run a dependency resolution computation. +runDep :: Config -> (String, String) -> DepM a -> IO (AST Stm) +runDep cfg mainmod m = do + res <- runStateT (runEitherT m) (initState cfg mainmod) + case res of + (Right _, st) -> + return $ defs st nullRet + (Left (Name f (Just (p, m))), _) -> do + error $ msg m f + where + msg "Main" "main" = + "Unable to locate a main function.\n" ++ + "If your main function is not `Main.main' you must specify it using " ++ + "`-main-is',\n" ++ + "for instance, `-main-is MyModule.myMain'.\n" ++ + "If your progam intentionally has no main function," ++ + " please use `--dont-link' to avoid this error." + msg m f = + "Unable to locate function `" ++ f ++ "' in module `" ++ m ++ "'!" -- | Return the module the given variable resides in. -getModuleOf :: FilePath -> Name -> DepM Module -getModuleOf libpath v = +getModuleOf :: [FilePath] -> Name -> DepM Module +getModuleOf libpaths v@(Name n _) = case moduleOf v of Just "GHC.Prim" -> return foreignModule Just "" -> return foreignModule - Just m -> getModule libpath (maybe "main" id $ pkgOf v) m - _ -> return foreignModule + Nothing -> return foreignModule + Just ":Main" -> do + (p, m) <- mainmod `fmap` get + getModuleOf libpaths (Name n (Just (p, m))) + Just m -> do + mm <- getModule libpaths (maybe "main" id $ pkgOf v) m + case mm of + Just m' -> return m' + _ -> left v -- | Return the module at the given path, loading it into cache if it's not -- already there. -getModule :: FilePath -> String -> String -> DepM Module -getModule libpath pkgid modname = do - st <- get - case M.lookup modname (modules st) of - Just m -> - return m - _ -> do - liftIO $ putStrLn $ "Linking " ++ modname - m <- liftIO $ readModule libpath pkgid modname - put st {modules = M.insert modname m (modules st)} - return m +getModule :: [FilePath] -> String -> String -> DepM (Maybe Module) +getModule libpaths pkgid modname = do + st <- get + case M.lookup modname (modules st) of + Just m -> do + return $ Just m + _ -> do + info $ "Linking " ++ modname + go libpaths + where + go (libpath:lps) = do + mm <- liftIO $ readModule libpath pkgid modname + case mm of + Just m -> do + st <- get + put st {modules = M.insert modname m (modules st)} + return (Just m) + _ -> do + go lps + go [] = do + return Nothing -- | Add a new definition and its dependencies. If the given identifier has -- already been added, it's just ignored. -addDef :: FilePath -> String -> Name -> DepM () -addDef libpath pkgid v = do +addDef :: [FilePath] -> String -> Name -> DepM () +addDef libpaths pkgid v = do st <- get when (not $ v `S.member` alreadySeen st) $ do - m <- getModuleOf libpath v - + m <- getModuleOf libpaths v -- getModuleOf may update the state, so we need to refresh it st' <- get let dependencies = maybe S.empty id (M.lookup v (modDeps m)) put st' {alreadySeen = S.insert v (alreadySeen st')} - S.foldl' (\a x -> a >> addDef libpath pkgid x) (return ()) dependencies + S.foldl' (\a x -> a >> addDef libpaths pkgid x) (return ()) dependencies -- addDef _definitely_ updates the state, so refresh once again st'' <- get - let Name comment _ = v - defs' = - maybe (defs st'') - (\body -> defs st'' . newVar True (internalVar v comment) body) - (M.lookup v (modDefs m)) + let Name cmnt _ = v + defs' = + maybe (defs st'') + (\body -> defs st'' . newVar True (internalVar v cmnt) body) + (M.lookup v (modDefs m)) put st'' {defs = defs'} diff --git a/src/Haste/Module.hs b/src/Haste/Module.hs --- a/src/Haste/Module.hs +++ b/src/Haste/Module.hs @@ -1,10 +1,8 @@ -- | Read and write JSMods. -module Haste.Module (writeModule, readModule, readModuleFingerprint) where +module Haste.Module (writeModule, readModule) where import Module (moduleNameSlashes, mkModuleName) import qualified Data.ByteString.Lazy as B -import System.FilePath -import System.Directory -import System.IO +import Control.Shell import Control.Applicative import Data.JSTarget import Data.Binary @@ -18,37 +16,37 @@ flip addExtension jsmodExt $ basepath pkgid (moduleNameSlashes $ mkModuleName modname) -readModuleFingerprint :: FilePath -> String -> String -> IO Fingerprint -readModuleFingerprint basepath pkgid modname = do - x <- doesFileExist path - let path' = if x then path else syspath - withFile path' ReadMode $ \h -> do - fp <- decode <$> B.hGetContents h - return $! fp - where - path = moduleFilePath "" "" modname - syspath = moduleFilePath basepath pkgid modname - -- | Write a module to file, with the extension specified in `fileExt`. -- Assuming that fileExt = "jsmod", a module Foo.Bar is written to -- 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 _ _) = do - createDirectoryIfMissing True (takeDirectory path) - B.writeFile path (encode m) +writeModule basepath m@(Module pkgid modname _ _) = + fromRight "writeModule" . shell $ do + mkdir True (takeDirectory path) + liftIO $ B.writeFile path (encode m) where path = moduleFilePath basepath pkgid modname -- | 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. -readModule :: FilePath -> String -> String -> IO Module -readModule basepath pkgid modname = do - x <- doesFileExist path - let path' = if x then path else syspath - decode <$> B.readFile path' +readModule :: FilePath -> String -> String -> IO (Maybe Module) +readModule basepath pkgid modname = fromRight "readModule" . shell $ do + x <- isFile path + let path' = if x then path else syspath + isF <- isFile path' + if isF + then Just . decode <$> liftIO (B.readFile path') + else return Nothing where path = moduleFilePath "." pkgid modname syspath = moduleFilePath basepath pkgid modname + +fromRight :: String -> IO (Either String b) -> IO b +fromRight from m = do + ex <- m + case ex of + Right x -> return x + Left e -> fail $ "shell expression failed in " ++ from ++ ": " ++ e diff --git a/src/Haste/Opts.hs b/src/Haste/Opts.hs new file mode 100644 --- /dev/null +++ b/src/Haste/Opts.hs @@ -0,0 +1,190 @@ +module Haste.Opts (hasteOpts, helpHeader) where +import System.Console.GetOpt +import Haste.Config +import Haste.Environment +import Data.JSTarget.PP (debugPPOpts) +import Data.List +import Control.Shell (()) + +-- | Haste's command line options. The boolean indicates whether we're running +-- unbooted or not. When unbooted, --libinstall will install jsmods into the +-- system jsmod dir rather than the user one. +hasteOpts :: Bool -> [OptDescr (Config -> Config)] +hasteOpts unbooted = [ + Option "" ["debug"] + (NoArg $ \cfg -> cfg {ppOpts = debugPPOpts}) $ + "Output indented, fairly readable code, with all " ++ + "external names included in comments.", + Option "" ["ddisable-js-opts"] + (NoArg $ \cfg -> cfg {optimize = False}) $ + "Don't perform any optimizations on the JS at all.", + Option "" ["dtrace-primops"] + (NoArg $ \cfg -> cfg {tracePrimops = True, + rtsLibs = debugLib : rtsLibs cfg}) $ + "Trace primops. Not really useful unless Haste was booted with " ++ + "option.", + Option "" ["dont-link"] + (NoArg $ \cfg -> cfg {performLink = False}) $ + "Don't link generated .jsmod files into a .js blob.", + Option "" ["full-unicode"] + (NoArg fullUnicode) $ + "Enable full generalCategory Unicode support. " ++ + "May bloat output by upwards of 150 KB.", + Option "?" ["help"] + (NoArg id) $ + "Display this message.", + Option "" ["libinstall"] + (NoArg $ \cfg -> cfg {targetLibPath = if unbooted + then jsmodSysDir + else jsmodUserDir, + performLink = False}) $ + "Install .jsmod files into the user's library. " ++ + "Implies --dont-link.", + Option "" ["onexec"] + (NoArg $ \cfg -> cfg {appStart = startCustom "onexec"}) $ + "Launch application immediately when the JS file is loaded. " ++ + "Shorthand for --start=onexec.", + Option "" ["onload"] + (NoArg $ \cfg -> cfg {appStart = startCustom "onload"}) $ + "Launch application on window.onload. " ++ + "Shorthand for --start=onload.", + Option "" ["opt-all"] + (NoArg optAllSafe) $ + "Enable all safe optimizations. Equivalent to --opt-minify " ++ + "--opt-whole-program.", + Option "" ["opt-unsafe"] + (NoArg optAllUnsafe) $ + "Enable all optimizations, safe and unsafe. Equivalent to " ++ + "--opt-all --opt-unsafe-ints", + Option "" ["opt-minify"] + (OptArg updateClosureCfg "PATH") $ + "Minify JS output using Google Closure compiler. " ++ + "Optionally, use the Closure compiler located at PATH.", + Option "" ["opt-minify-flag"] + (ReqArg updateClosureFlags "FLAG") $ + "Pass a flag to Closure. " ++ + "To minify programs in strict mode, use " ++ + "--opt-minify-flag='--language_in=ECMASCRIPT5_STRICT'", + Option "" ["opt-unsafe-ints"] + (NoArg unsafeMath) $ + "Enable unsafe Int arithmetic. Implies --opt-unsafe-mult " ++ + "--opt-vague-ints", + Option "" ["opt-unsafe-mult"] + (NoArg unsafeMul) $ + "Use Javascript's built-in multiplication operator for " + ++ "fixed precision integer multiplication. This may speed " + ++ "up Int multiplication by a factor of at least four, " + ++ "but may give incorrect results when the product " + ++ "falls outside the interval [-2^52, 2^52]. In browsers " + ++ "which support Math.imul, this optimization will likely be " + ++ "slower than the default.", + Option "" ["opt-vague-ints"] + (NoArg vagueInts) $ + "Int math has 53 bits of precision, but gives incorrect " + ++ "results rather than properly wrapping around when " + ++ "those 53 bits are exceeded. Bitwise operations still " + ++ "only work on the lowest 32 bits.", + Option "" ["opt-whole-program"] + (NoArg enableWholeProgramOpts) $ + "Perform optimizations over the whole program during linking. " ++ + "May significantly increase link time.", + Option "o" ["out"] + (ReqArg (\f cfg -> cfg {outFile = \_ _ -> f}) "FILE") $ + "Write JS output to FILE.", + Option "" ["outdir"] + (ReqArg (\d cfg -> cfg {targetLibPath = d}) "DIR") $ + "Write intermediate files to DIR.", + Option "" ["output-html"] + (NoArg $ \cfg -> cfg {outputHTML = True}) $ + "Write the JS output to an HTML file together with a simple " ++ + "HTML skeleton.", + Option "" ["start"] + (ReqArg (\start cfg -> cfg {appStart = startCustom start}) + "CODE") $ + "Specify custom start code. '$HASTE_MAIN' will be replaced with " ++ + "the application's main function. For instance, " ++ + "--start='$(\"foo\").onclick($HASTE_MAIN);' " ++ + "will use jQuery to launch the application whenever the element " ++ + "with the id \"foo\" is clicked.", + Option "v" ["verbose"] + (NoArg $ \cfg -> cfg {verbose = True}) $ + "Display even the most obnoxious warnings and messages.", + Option "" ["with-js"] + (ReqArg (\js c -> c {jsExternals = jsExternals c ++ commaBreak js}) + "FILES") $ + "Link the given comma-separated list of JS files into the final " ++ + "JS bundle." + ] + +helpHeader :: String +helpHeader = unlines [ + "Usage: hastec [OPTIONS] FILES", + "", + "To compile a program with a main function residing in prog.hs:", + "\n hastec prog.hs\n", + "The resulting code may be a bit on the large and/or slow side. For release", + "builds, using --opt-all is strongly recommended. For debugging, use the --debug", + "option to increase the readability of the produced code somewhat.", + "", + "By default, programs start executing when the window.onload event fires.", + "This is not always what we want. For instance, when running the test suite", + "we want the program to start executing immediately upon being loaded into", + "the interpreter. This behavior can be controlled using the --onload, --onexec", + "and --start options.", + "", + "A summary of the available options are given below." + ] + +-- | Like 'words', except it breaks on commas instead of spaces. +commaBreak :: String -> [String] +commaBreak [] = [] +commaBreak s = + case span (/= ',') s of + (w, ws) -> w : commaBreak (drop 1 ws) + +-- | Don't wrap Ints. +vagueInts :: Config -> Config +vagueInts cfg = cfg {wrapIntMath = id} + +-- | Use fast but unsafe multiplication. +unsafeMul :: Config -> Config +unsafeMul cfg = cfg {multiplyIntOp = fastMultiply} + +-- | Enable all unsafe math ops. Remember to update the info text when changing +-- this! +unsafeMath :: Config -> Config +unsafeMath = vagueInts . unsafeMul + +-- | Enable all optimizations, both safe and unsafe. +optAllUnsafe :: Config -> Config +optAllUnsafe = optAllSafe . unsafeMath . enableWholeProgramOpts + +-- | Enable all safe optimizations. +optAllSafe :: Config -> Config +optAllSafe = enableWholeProgramOpts . updateClosureCfg Nothing + +-- | Set the path to the Closure compiler.jar to use. +updateClosureCfg :: Maybe FilePath -> Config -> Config +updateClosureCfg (Just fp) cfg = + cfg {useGoogleClosure = Just fp} +updateClosureCfg _ cfg = + cfg {useGoogleClosure = Just closureCompiler} + +-- | Add flags for Google Closure to use +updateClosureFlags :: String -> Config -> Config +updateClosureFlags arg cfg = cfg { + useGoogleClosureFlags = useGoogleClosureFlags cfg ++ commaBreak arg} + +-- | Enable optimizations over the entire program. +enableWholeProgramOpts :: Config -> Config +enableWholeProgramOpts cfg = cfg {wholeProgramOpts = True} + +-- | Save some space and performance by using degenerate implementations of +-- the Unicode functions. +fullUnicode :: Config -> Config +fullUnicode cfg = + cfg {rtsLibs = unicode : filter (not . (cheap `isSuffixOf`)) libs} + where + libs = rtsLibs cfg + unicode = jsDir "unicode.js" + cheap = jsDir "cheap-unicode.js" diff --git a/src/Haste/PrimOps.hs b/src/Haste/PrimOps.hs --- a/src/Haste/PrimOps.hs +++ b/src/Haste/PrimOps.hs @@ -302,7 +302,7 @@ PopCnt16Op -> Right $ callForeign "popCnt" [head xs] PopCnt32Op -> Right $ callForeign "popCnt" [head xs] DelayOp -> Right $ defState - SeqOp -> Right $ callForeign "E" [head xs] + SeqOp -> Right $ eval $ head xs AtomicallyOp -> Right $ callSaturated (xs !! 0) [] -- Get the data constructor tag from a value. DataToTagOp -> callF "dataToTag" diff --git a/src/Haste/Version.hs b/src/Haste/Version.hs --- a/src/Haste/Version.hs +++ b/src/Haste/Version.hs @@ -2,24 +2,27 @@ module Haste.Version (hasteVersion, ghcVersion, bootVersion, needsReboot, BootVer (..), bootFile) where import System.IO.Unsafe -import System.Directory -import System.FilePath (()) +import Control.Shell ((), shell, isFile, run) import System.IO import Data.Version import Config (cProjectVersion) -import Haste.Environment (hasteDir) +import Haste.Environment (hasteSysDir, ghcBinary) hasteVersion :: Version -hasteVersion = Version [0, 3] [] +hasteVersion = Version [0, 4] [] ghcVersion :: String -ghcVersion = cProjectVersion +ghcVersion = unsafePerformIO $ do + res <- shell $ run ghcBinary ["--numeric-version"] "" + case res of + Right ver -> return $ init ver -- remove trailing newline + _ -> return cProjectVersion bootVersion :: BootVer bootVersion = BootVer hasteVersion ghcVersion bootFile :: FilePath -bootFile = hasteDir "booted" +bootFile = hasteSysDir "booted" data BootVer = BootVer Version String deriving (Read, Show) @@ -27,9 +30,9 @@ -- format triggers a full reboot. needsReboot :: Bool needsReboot = unsafePerformIO $ do - exists <- doesFileExist bootFile - if exists - then do + exists <- shell $ isFile bootFile + case exists of + Right True -> do fh <- openFile bootFile ReadMode bootedVerString <- hGetLine fh hClose fh @@ -38,5 +41,5 @@ return $ hasteVer /= hasteVersion || ghcVer /= ghcVersion _ -> return True - else + _ -> do return True diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,45 +1,38 @@ {-# LANGUAGE CPP #-} module Main (main) where import GHC -import GHC.Paths (libdir) import HscMain import Outputable (showPpr) -import DynFlags hiding (flags) +import DynFlags import TidyPgm import CorePrep import CoreToStg import StgSyn (StgBinding) import HscTypes -import Module (moduleNameSlashes) import GhcMonad +import Module (packageIdString) import System.Environment (getArgs) import Control.Monad (when) import Haste +import Haste.Args +import Haste.Opts import Haste.Environment import Haste.Version -import Args -import ArgSpecs -import System.FilePath (addExtension) import System.IO -import System.Process (runProcess, waitForProcess, rawSystem) -import System.Exit (ExitCode (..), exitFailure) -import System.Directory (renameFile) -import Filesystem (getModified, isFile) +import System.Exit (exitFailure) import Data.Version import Data.List -import Data.String -import qualified Data.ByteString.Char8 as B import qualified Control.Shell as Sh -logStr :: String -> IO () -logStr = hPutStrLn stderr +logStr :: Config -> String -> IO () +logStr cfg = when (verbose cfg) . hPutStrLn stderr rebootMsg :: String rebootMsg = "Haste needs to be rebooted; please run haste-boot" printInfo :: IO () printInfo = do - ghc <- runGhc (Just libdir) getSessionDynFlags + ghc <- runGhc (Just ghcLibDir) getSessionDynFlags putStrLn $ formatInfo $ compilerInfo ghc where formatInfo = ('[' :) . tail . unlines . (++ ["]"]) . map ((',' :) . show) @@ -52,6 +45,8 @@ putStrLn ghcVersion >> return False | "--info" `elem` args = printInfo >> return False + | "--print-libdir" `elem` args = + putStrLn ghcLibDir >> return False | "--version" `elem` args = putStrLn (showVersion hasteVersion) >> return False | "--supported-extensions" `elem` args = @@ -63,6 +58,7 @@ main :: IO () main = do + initUserPkgDB args <- fmap (++ packageDBArgs) getArgs runCompiler <- preArgs args when (runCompiler) $ do @@ -73,30 +69,40 @@ #if __GLASGOW_HASKELL__ >= 706 packageDBArgs = ["-no-global-package-db", "-no-user-package-db", - "-package-db " ++ pkgDir] + "-package-db " ++ pkgSysDir, + "-package-db " ++ pkgUserDir ] #else packageDBArgs = ["-no-user-package-conf", - "-package-conf " ++ pkgDir] + "-package-conf " ++ pkgSysDir] #endif -- | Call vanilla GHC; used for boot files and the like. callVanillaGHC :: [String] -> IO () callVanillaGHC args = do - _ <- rawSystem "ghc" (filter noHasteArgs args) + _ <- Sh.shell $ Sh.run_ ghcBinary (filter noHasteArgs args) "" return () where noHasteArgs x = x /= "--libinstall" && x /= "--unbooted" +initUserPkgDB :: IO () +initUserPkgDB = do + _ <- Sh.shell $ do + pkgDirExists <- Sh.isDirectory pkgUserDir + when (not pkgDirExists) $ do + Sh.mkdir True pkgUserLibDir + Sh.runInteractive ghcPkgBinary ["init", pkgUserDir] + return () + -- | Run the compiler if everything's satisfactorily booted, otherwise whine -- and exit. hasteMain :: [String] -> IO () hasteMain args | not needsReboot = - compiler ("-O2" : args) + compiler False ("-O2" : args) | otherwise = do if "--unbooted" `elem` args - then compiler (filter (/= "--unbooted") ("-O2" : args)) + then compiler True (filter (/= "--unbooted") ("-O2" : args)) else fail rebootMsg -- | Determine whether all given args are handled by Haste, or if we need to @@ -109,65 +115,66 @@ someoneElsesProblems = [".c", ".cmm", ".hs-boot", ".lhs-boot"] -- | The main compiler driver. -compiler :: [String] -> IO () -compiler cmdargs = do - let cmdargs' | "-debug" `elem` cmdargs = "--debug":"--trace-primops":cmdargs - | otherwise = cmdargs - argRes = handleArgs defConfig argSpecs cmdargs' +compiler :: Bool -> [String] -> IO () +compiler unbooted cmdargs = do + let argRes = parseArgs (hasteOpts unbooted) helpHeader cmdargs usedGhcMode = if "-c" `elem` cmdargs then OneShot else CompManager case argRes of -- We got --help as an argument - display help and exit. - Left help -> putStrLn help + Left help -> putStr help -- We got a config and a set of arguments for GHC; let's compile! - Right (cfg, ghcargs) -> do + Right (mkConfig, ghcargs) -> do + let config = mkConfig def + -- Parse static flags, but ignore profiling. (ghcargs', _) <- parseStaticFlags [noLoc a | a <- ghcargs, a /= "-prof"] - runGhc (Just libdir) $ handleSourceError (const $ liftIO exitFailure) $ do + runGhc (Just ghcLibDir) $ do -- Handle dynamic GHC flags. Make sure __HASTE__ is #defined. let args = "-D__HASTE__" : map unLoc ghcargs' + justDie = const $ liftIO exitFailure dynflags <- getSessionDynFlags - (dynflags', files, _) <- parseDynamicFlags dynflags (map noLoc args) - _ <- setSessionDynFlags dynflags' {ghcLink = NoLink, - ghcMode = usedGhcMode} + defaultCleanupHandler dynflags $ handleSourceError justDie $ do + (dynflags', files, _) <- parseDynamicFlags dynflags (map noLoc args) + _ <- setSessionDynFlags dynflags' {ghcLink = NoLink, + ghcMode = usedGhcMode} - -- Prepare and compile all needed targets. - let files' = map unLoc files - printErrorAndDie e = printException e >> liftIO exitFailure - deps <- handleSourceError printErrorAndDie $ do - ts <- mapM (flip guessTarget Nothing) files' - setTargets ts - _ <- load LoadAllTargets - depanal [] False - mapM_ (compile cfg dynflags') deps + -- Prepare and compile all needed targets. + let files' = map unLoc files + printErrorAndDie e = printException e >> liftIO exitFailure + deps <- handleSourceError printErrorAndDie $ do + ts <- mapM (flip guessTarget Nothing) files' + setTargets ts + _ <- load LoadAllTargets + depanal [] False + let cfg = fillLinkerConfig dynflags' config + mapM_ (compile cfg dynflags') deps - -- Link everything together into a .js file. - when (performLink cfg) $ liftIO $ do - flip mapM_ files' $ \file -> do - let outfile = outFile cfg cfg file - logStr $ "Linking " ++ outfile + -- Link everything together into a .js file. + when (performLink cfg) $ liftIO $ do + flip mapM_ files' $ \file -> do + let outfile = outFile cfg cfg file + logStr cfg $ "Linking program " ++ outfile #if __GLASGOW_HASKELL__ >= 706 - let pkgid = showPpr dynflags $ thisPackage dynflags' + let pkgid = showPpr dynflags $ thisPackage dynflags' #else - let pkgid = showPpr $ thisPackage dynflags' + let pkgid = showPpr $ thisPackage dynflags' #endif - link cfg pkgid file - case useGoogleClosure cfg of - Just clopath -> closurize clopath - outfile - (useGoogleClosureFlags cfg) - _ -> return () - when (outputHTML cfg) $ do - res <- Sh.shell $ Sh.withCustomTempFile "." $ \tmp h -> do - prog <- Sh.file outfile - Sh.hPutStrLn h (htmlSkeleton outfile prog) - Sh.liftIO $ hClose h - Sh.mv tmp outfile - case res of - Right () -> return () - Left err -> error $ "Couldn't output HTML file: " ++ err + link cfg pkgid file + case useGoogleClosure cfg of + Just clopath -> closurize cfg clopath outfile + _ -> return () + when (outputHTML cfg) $ do + res <- Sh.shell $ Sh.withCustomTempFile "." $ \tmp h -> do + prog <- Sh.file outfile + Sh.hPutStrLn h (htmlSkeleton outfile prog) + Sh.liftIO $ hClose h + Sh.mv tmp outfile + case res of + Right () -> return () + Left err -> error $ "Couldn't output HTML file: " ++ err -- | Produce an HTML skeleton with an embedded JS program. htmlSkeleton :: FilePath -> String -> String @@ -184,9 +191,6 @@ prepare dynflags theMod = do env <- getSession let name = moduleName $ ms_mod theMod -#if __GLASGOW_HASKELL__ >= 707 - mod = ms_mod theMod -#endif pgm <- parseModule theMod >>= typecheckModule >>= desugarModule @@ -194,7 +198,7 @@ >>= liftIO . tidyProgram env >>= prepPgm env . fst #if __GLASGOW_HASKELL__ >= 707 - >>= liftIO . coreToStg dynflags mod + >>= liftIO . coreToStg dynflags (ms_mod theMod) #else >>= liftIO . coreToStg dynflags #endif @@ -208,82 +212,54 @@ #endif return prepd - -- | Run Google Closure on a file. -closurize :: FilePath -> FilePath -> [String] -> IO () -closurize cloPath file arguments = do - logStr $ "Running the Google Closure compiler on " ++ file ++ "..." - let cloFile = file `addExtension` ".clo" - cloOut <- openFile cloFile WriteMode - build <- runProcess "java" - (["-jar", cloPath, - "--compilation_level", "ADVANCED_OPTIMIZATIONS", - "--jscomp_off", "globalThis", file] - ++ arguments) - Nothing - Nothing - Nothing - (Just cloOut) - Nothing - res <- waitForProcess build - hClose cloOut +closurize :: Config -> FilePath -> FilePath -> IO () +closurize cfg cloPath f = do + let arguments = useGoogleClosureFlags cfg + logStr cfg $ "Running the Google Closure compiler on " ++ f ++ "..." + let cloFile = f `Sh.addExtension` ".clo" + res <- Sh.shell $ do + str <- Sh.run "java" + (["-jar", cloPath, + "--compilation_level", "ADVANCED_OPTIMIZATIONS", + "--jscomp_off", "globalThis", f] + ++ arguments) "" + Sh.file cloFile str :: Sh.Shell () + Sh.mv cloFile f case res of - ExitFailure n -> - fail $ "Couldn't execute Google Closure compiler: " ++ show n - ExitSuccess -> - renameFile cloFile file - --- | Generate a unique fingerprint for the compiler, command line arguments, --- etc. -genFingerprint :: String -> FilePath -> [String] -> Fingerprint -genFingerprint modname targetpath args = - {- md5sum $ B.pack $ -} show [ - modname, - targetpath, - show bootVersion, - show args - ] + Left e -> fail $ "Couldn't execute Google Closure compiler: " ++ e + Right _ -> return () -- | Compile a module into a .jsmod intermediate file. compile :: (GhcMonad m) => Config -> DynFlags -> ModSummary -> m () compile cfg dynflags modSummary = do - fp <- liftIO $ fmap (genFingerprint myName targetpath) getArgs - should_recompile <- liftIO $ shouldRecompile fp modSummary targetpath - when should_recompile $ do - case ms_hsc_src modSummary of - HsBootFile -> liftIO $ logStr $ "Skipping boot " ++ myName - _ -> do - (pgm, name) <- prepare dynflags modSummary + case ms_hsc_src modSummary of + HsBootFile -> liftIO $ logStr cfg $ "Skipping boot " ++ myName + _ -> do + (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' fp pkgid name pgm - liftIO $ logStr $ "Compiling " ++ myName ++ " into " ++ targetpath - liftIO $ writeModule targetpath theCode + theCode = generate cfg' pkgid name pgm + liftIO $ logStr cfg $ "Compiling " ++ myName ++ " into " ++ targetpath + liftIO $ writeModule targetpath theCode where myName = moduleNameString $ moduleName $ ms_mod modSummary targetpath = targetLibPath cfg -shouldRecompile :: Fingerprint -> ModSummary -> FilePath -> IO Bool -shouldRecompile _ _ _ = return True -{- -shouldRecompile fp ms path = do - exists <- isFile fpPath - if exists - then do - fp' <- readModuleFingerprint path pkgid modname - jsmtime <- getModified fpPath - return $ ms_hs_date ms > jsmtime || fp /= fp' - else do - return True +-- | Fill in linkage info, such as whether to link at all and what the program +-- entry point is. +fillLinkerConfig :: DynFlags -> Config -> Config +fillLinkerConfig df cfg = + cfg { + mainMod = mainmod, + performLink = maybe False (const $ performLink cfg) mainmod + } where - modname = moduleNameString $ ms_mod_name ms - file = moduleNameSlashes (ms_mod_name ms) ++ ".jsmod" - path' = path ++ "/" ++ pkgid ++ "/" ++ file - pkgid = showOutputable $ modulePackageId $ ms_mod ms - fpPath = fromString path' --} + mainmod = + Just (packageIdString $ modulePackageId (mainModIs df), + moduleNameString $ moduleName (mainModIs df)) diff --git a/src/haste-boot.hs b/src/haste-boot.hs --- a/src/haste-boot.hs +++ b/src/haste-boot.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} import Prelude hiding (read) -import System.Directory import Network.HTTP import Network.Browser hiding (err) import Network.URI @@ -12,14 +11,20 @@ import System.Environment (getArgs) import System.Exit import Control.Monad -import qualified Codec.Archive.Zip as Zip import Haste.Environment import Haste.Version import Control.Shell import Data.Char (isDigit) import Control.Monad.IO.Class (liftIO) -import Args +import Haste.Args +import System.Console.GetOpt +#if __GLASGOW_HASKELL__ >= 708 +baseDir = "base-ghc-7.8" +#else +baseDir = "base-ghc-7.6" +#endif + downloadFile :: String -> Shell BS.ByteString downloadFile f = do (_, rsp) <- liftIO $ Network.Browser.browse $ do @@ -51,40 +56,44 @@ forceBoot = False } -specs :: [ArgSpec Cfg] +specs :: [OptDescr (Cfg -> Cfg)] specs = [ - ArgSpec { optName = "force", - updateCfg = \cfg _ -> cfg {forceBoot = True}, - info = "Re-boot Haste even if already properly booted."}, - ArgSpec { optName = "local", - updateCfg = \cfg _ -> cfg {useLocalLibs = True}, - info = "Use libraries from source repository rather than " ++ - "downloading a matching set from the Internet. " ++ - "This is nearly always necessary when installing " ++ - "Haste from Git rather than from Hackage. " ++ - "When using --local, your current working directory " ++ - "must be the root of the Haste source tree."}, - ArgSpec { optName = "no-closure", - updateCfg = \cfg _ -> cfg {getClosure = False}, - info = "Don't download Closure compiler. You won't be able " ++ - "to use --opt-google-closure, unless you manually " ++ - "give it the path to compiler.jar."}, - ArgSpec { optName = "no-libs", - updateCfg = \cfg _ -> cfg {getLibs = False}, - info = "Don't install any libraries. This is probably not " ++ - "what you want."}, - ArgSpec { optName = "trace-primops", - updateCfg = \cfg _ -> cfg {tracePrimops = True}, - info = "Build standard libs for tracing of primitive " ++ - "operations. Only use if you're debugging the code " ++ - "generator."} + Option "" ["force"] + (NoArg $ \cfg -> cfg {forceBoot = True}) $ + "Re-boot Haste even if already properly booted.", + Option "" ["local"] + (NoArg $ \cfg -> cfg {useLocalLibs = True}) $ + "Use libraries from source repository rather than " ++ + "downloading a matching set from the Internet. " ++ + "This is nearly always necessary when installing " ++ + "Haste from Git rather than from Hackage. " ++ + "When using --local, your current working directory " ++ + "must be the root of the Haste source tree.", + Option "" ["no-closure"] + (NoArg $ \cfg -> cfg {getClosure = False}) $ + "Don't download Closure compiler. You won't be able " ++ + "to use --opt-minify, unless you manually " ++ + "give hastec the path to compiler.jar.", + Option "" ["no-libs"] + (NoArg $ \cfg -> cfg {getLibs = False}) $ + "Don't install any libraries. This is probably not " ++ + "what you want.", + Option "" ["trace-primops"] + (NoArg $ \cfg -> cfg {tracePrimops = True}) $ + "Build standard libs for tracing of primitive " ++ + "operations. Only use if you're debugging the code " ++ + "generator." ] +hdr :: String +hdr = "Fetch, build and install all libraries necessary to use Haste.\n" + main :: IO () main = do args <- getArgs - case handleArgs defCfg specs args of - Right (cfg, _) -> do + case parseArgs specs hdr args of + Right (mkConfig, _) -> do + let cfg = mkConfig defCfg when (needsReboot || forceBoot cfg) $ do res <- shell $ if useLocalLibs cfg then bootHaste cfg "." @@ -102,17 +111,27 @@ when (getLibs cfg) $ do when (not $ useLocalLibs cfg) $ do fetchLibs tmpdir - exists <- isDirectory hasteInstDir - when exists $ rmdir hasteInstDir - exists <- isDirectory jsmodDir - when exists $ rmdir jsmodDir - exists <- isDirectory pkgDir - when exists $ rmdir pkgDir + mapM_ clearDir [hasteInstUserDir, jsmodUserDir, pkgUserDir, + hasteInstSysDir, jsmodSysDir, pkgSysDir] buildLibs cfg + when (portableHaste) $ do + mapM_ relocate ["array", "bytestring", "containers", "data-default", + "data-default-class", "data-default-instances-base", + "data-default-instances-containers", + "data-default-instances-dlist", + "data-default-instances-old-locale", + "deepseq", "dlist", "haste-lib", "integer-gmp", + "monads-tf", "old-locale", "transformers"] when (getClosure cfg) $ do installClosure file bootFile (show bootVersion) +clearDir :: FilePath -> Shell () +clearDir dir = do + exists <- isDirectory dir + when exists $ rmdir dir + + -- | Fetch the Haste base libs. fetchLibs :: FilePath -> Shell () fetchLibs tmpdir = do @@ -127,27 +146,21 @@ installClosure :: Shell () installClosure = do echo "Downloading Google Closure compiler..." - downloadAndUnpackClosure `orElse` do + downloadClosure `orElse` do echo "Couldn't install Closure compiler; continuing without." where - downloadAndUnpackClosure = do - file <- downloadFile closureURI - let cloArch = Zip.toArchive file - case Zip.findEntryByPath "compiler.jar" cloArch of - Just compiler -> - liftIO $ BS.writeFile closureCompiler (Zip.fromEntry compiler) - _ -> - fail "Unable to unpack Closure compiler" + downloadClosure = do + downloadFile closureURI >>= (liftIO . BS.writeFile closureCompiler) closureURI = - "http://dl.google.com/closure-compiler/compiler-latest.zip" + "http://valderman.github.io/haste-libs/compiler.jar" -- | Build haste's base libs. buildLibs :: Cfg -> Shell () buildLibs cfg = do -- Set up dirs and copy includes - mkdir True $ pkgLibDir - cpDir "include" hasteDir - run_ hastePkgBinary ["update", "libraries" "rts.pkg"] "" + mkdir True $ pkgSysLibDir + cpDir "include" hasteSysDir + run_ hastePkgBinary ["update", "--global", "libraries" "rts.pkg"] "" inDirectory "libraries" $ do -- Install ghc-prim @@ -155,7 +168,7 @@ hasteInst ["configure", "--solver", "topdown"] hasteInst $ ["build", "--install-jsmods"] ++ ghcOpts run_ hasteInstHisBinary ["ghc-prim-0.3.0.0", "dist" "build"] "" - run_ hastePkgBinary ["update", "packageconfig"] "" + run_ hastePkgBinary ["update", "--global", "packageconfig"] "" -- Install integer-gmp; double install shouldn't be needed anymore. run_ hasteCopyPkgBinary ["Cabal"] "" @@ -163,7 +176,7 @@ hasteInst ("install" : "--solver" : "topdown" : ghcOpts) -- Install base - inDirectory "base" $ do + inDirectory baseDir $ do basever <- file "base.cabal" >>= return . dropWhile (not . isDigit) . head @@ -176,15 +189,21 @@ pkgdb = "--package-db=dist" "package.conf.inplace" run_ hasteInstHisBinary [base, "dist" "build"] "" run_ hasteCopyPkgBinary [base, pkgdb] "" - cpDir "include" hasteDir + forEachFile "include" $ \f -> cp f (hasteSysDir "include") -- Install array and haste-lib forM_ ["array", "haste-lib"] $ \pkg -> do inDirectory pkg $ hasteInst ("install" : ghcOpts) + + -- Export monads-tf; it seems to be hidden by default + run_ hastePkgBinary ["expose", "monads-tf"] "" where ghcOpts = concat [ if tracePrimops cfg then ["--ghc-option=-debug"] else [], ["--ghc-option=-DHASTE_HOST_WORD_SIZE_IN_BITS=" ++ show hostWordSize] ] hasteInst args = - run_ hasteInstBinary ("--unbooted" : args) "" + run_ hasteInstBinary ("--install-global" : "--unbooted" : args) "" + +relocate :: String -> Shell () +relocate pkg = run_ hastePkgBinary ["relocate", pkg] "" 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 @@ -27,8 +27,9 @@ copyFromDB :: [String] -> String -> Shell () copyFromDB pkgdbs package = do - pkgdesc <- run "ghc-pkg" (["describe", package] ++ pkgdbs) "" - run_ hastePkgBinary ["update", "-", "--force"] (fixPaths package pkgdesc) + pkgdesc <- run ghcPkgBinary (["describe", package] ++ pkgdbs) "" + run_ hastePkgBinary ["update", "-", "--force", "--global"] + (fixPaths package pkgdesc) -- | Hack a config to work with Haste. fixPaths :: String -> String -> String @@ -39,6 +40,7 @@ . map fixPath . filter (not . ("haddock" `isPrefixOf`)) . filter (not . ("hs-libraries:" `isPrefixOf`)) + . takeWhile (not . isPrefixOf "---") $ lines pkgtext fixPath str @@ -46,6 +48,8 @@ "library-dirs: " ++ importDir pkgname | isKey "import-dirs:" str = "import-dirs: " ++ importDir pkgname + | isKey "include-dirs:" str = + "include-dirs: " ++ includeDir | isKey "pkgroot:" str = "pkgroot: \"" ++ pkgRoot ++ "\"" | "-inplace" `isSuffixOf` str = @@ -58,5 +62,6 @@ isKey key str = and $ zipWith (==) key str - importDir = pkgLibDir - pkgRoot = hasteInstDir + importDir = "${pkgroot}" "libraries" "lib" + includeDir = "${pkgroot}" "include" + pkgRoot = "${pkgroot}" diff --git a/src/haste-inst.hs b/src/haste-inst.hs --- a/src/haste-inst.hs +++ b/src/haste-inst.hs @@ -1,16 +1,21 @@ -- | haste-inst - Haste wrapper for cabal. module Main where -import System.FilePath import System.Environment +import System.Exit import Haste.Environment +import Control.Shell import Data.List type Match = (String -> Bool, [String] -> [String]) cabal :: [String] -> IO () cabal args = do - runAndWait "cabal" (hasteargs ++ args) Nothing + res <- shell $ run_ "cabal" (hasteargs ++ args') "" + case res of + Left _ -> exitFailure + _ -> exitSuccess where + args' = [arg | arg <- args, arg /= "--install-global", arg /= "--global"] hasteargs | "build" `elem` args = ["--with-ghc=" ++ hasteBinary] @@ -18,9 +23,14 @@ ["--with-compiler=" ++ hasteBinary, "--with-hc-pkg=" ++ hastePkgBinary, "--with-hsc2hs=hsc2hs", - "--prefix=" ++ hasteInstDir, - "--package-db=" ++ pkgDir, - "-fhaste-inst"] + "-fhaste-inst"] ++ + if "--install-global" `elem` args || "--global" `elem` args + then ["--prefix=" ++ hasteInstSysDir, + "--package-db=" ++ pkgSysDir] + else ["--prefix=" ++ hasteInstUserDir, + "--package-db=" ++ pkgSysDir, + "--package-db=" ++ pkgUserDir] + main :: IO () main = do diff --git a/src/haste-install-his.hs b/src/haste-install-his.hs --- a/src/haste-install-his.hs +++ b/src/haste-install-his.hs @@ -2,43 +2,43 @@ -- | haste-install-his; install all .hi files in a directory. module Main where import Haste.Environment -import System.FilePath -import System.Directory import System.Environment import Control.Applicative import Control.Monad import Data.List import Data.Char +import Control.Shell main :: IO () main = do args <- getArgs case args of - [package, dir] -> installFromDir (pkgLibDir package) dir - _ -> putStrLn "Usage: haste-install-his pkgname dir" + [package, dir] -> shell $ installFromDir (pkgSysLibDir package) dir + _ -> shell $ echo "Usage: haste-install-his pkgname dir" + return () -getHiFiles :: FilePath -> IO [FilePath] +getHiFiles :: FilePath -> Shell [FilePath] getHiFiles dir = - filter (".hi" `isSuffixOf`) <$> getDirectoryContents dir + filter (".hi" `isSuffixOf`) <$> ls dir -getSubdirs :: FilePath -> IO [FilePath] +getSubdirs :: FilePath -> Shell [FilePath] getSubdirs dir = do - contents <- getDirectoryContents dir - someDirs <- mapM (\d -> (d,) <$> doesDirectoryExist (dir d)) contents + contents <- ls dir + someDirs <- mapM (\d -> (d,) <$> isDirectory (dir d)) contents return [path | (path, isDir) <- someDirs , isDir , head path /= '.' , isUpper (head path)] -installFromDir :: FilePath -> FilePath -> IO () +installFromDir :: FilePath -> FilePath -> Shell () installFromDir base path = do hiFiles <- getHiFiles path when (not $ null hiFiles) $ do - createDirectoryIfMissing True (pkgLibDir base) + mkdir True (pkgSysLibDir base) mapM_ (installHiFile base path) hiFiles getSubdirs path >>= mapM_ (\d -> installFromDir (base d) (path d)) -installHiFile :: FilePath -> FilePath -> FilePath -> IO () +installHiFile :: FilePath -> FilePath -> FilePath -> Shell () installHiFile to from file = do - putStrLn $ "Installing " ++ from file ++ "..." - copyFile (from file) (to file) + echo $ "Installing " ++ from file ++ "..." + cp (from file) (to file) diff --git a/src/haste-pkg.hs b/src/haste-pkg.hs --- a/src/haste-pkg.hs +++ b/src/haste-pkg.hs @@ -2,24 +2,67 @@ -- | haste-pkg; wrapper for ghc-pkg. module Main where import Control.Monad -import System.Environment -import System.Directory +import System.Environment (getArgs) import Haste.Environment +import Control.Shell +import System.Info (os) -main = do - args <- getArgs - pkgDirExists <- doesDirectoryExist pkgDir - when (not pkgDirExists) $ do - createDirectoryIfMissing True pkgLibDir - runAndWait "ghc-pkg" ["init", pkgDir] Nothing - runAndWait "ghc-pkg" (packages ++ map userToGlobal args) Nothing +main = shell $ do + args <- liftIO getArgs + case args of + ["relocate", pkg] -> relocate packages pkg + _ -> ghcPkg packages args where #if __GLASGOW_HASKELL__ >= 706 - packages = ["--no-user-package-db", - "--global-package-db=" ++ pkgDir] + packages = ["--global-package-db=" ++ pkgSysDir, + "--package-db=" ++ pkgSysDir, + "--package-db=" ++ pkgUserDir] #else packages = ["--no-user-package-conf", - "--global-conf=" ++ pkgDir] + "--global-conf=" ++ pkgUserDir] #endif - userToGlobal "--user" = "--global" - userToGlobal str = str + +ghcPkg :: [String] -> [String] -> Shell () +ghcPkg packages args = do + pkgDirExists <- isDirectory pkgUserDir + when (not pkgDirExists) $ do + mkdir True pkgUserLibDir + runInteractive ghcPkgBinary ["init", pkgUserDir] + pkgDirExists <- isDirectory pkgSysDir + when (not pkgDirExists) $ do + mkdir True pkgSysLibDir + runInteractive ghcPkgBinary ["init", pkgSysDir] + runInteractive ghcPkgBinary (packages ++ args) + +-- | Only global packages may be marked as relocatable! +-- May break horribly for general use, only reliable for Haste base packages. +relocate :: [String] -> String -> Shell () +relocate packages pkg = do + pi <- run ghcPkgBinary (packages ++ ["describe", pkg]) "" + run_ ghcPkgBinary (packages++["update","-","--force","--global"]) (reloc pi) + where + reloc = unlines . map fixPath . lines + + fixPath s + | isKey "library-dirs: " s = prefix s "library-dirs" importDir + | isKey "import-dirs: " s = prefix s "import-dirs" importDir + | isKey "haddock-interfaces: " s = prefix s "haddock-interfaces" importDir + | isKey "haddock-html: " s = prefix s "haddock-html" importDir + | isKey "include-dirs: " s = "include-dirs: " ++ includeDir + | otherwise = s + + prefix s pfx path = pfx ++ ": " ++ path stripPrefix s + + stripPrefix s = + case take 2 $ reverse $ splitPath s of + [second, first] -> first second + + isKey _ "" = + False + isKey key str = + and $ zipWith (==) key str + + importDir + | os == "mingw32" = "${pkgroot}" "libraries" + | otherwise = "${pkgroot}" "libraries" "lib" + includeDir = "${pkgroot}" "include"