haste-compiler 0.3 → 0.4
raw patch · 37 files changed
+1264/−846 lines, 37 filesdep +eitherdep −executable-pathdep −integer-gmpdep −temporarydep ~ghcdep ~shellmatesetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: either
Dependencies removed: executable-path, integer-gmp, temporary, time, zip-archive
Dependency ranges changed: ghc, shellmate
API changes (from Hackage documentation)
- Haste.Foreign: instance [overlap ok] (Marshal a, FFI b) => FFI (a -> b)
- Haste.Foreign: instance [overlap ok] Marshal a => FFI (IO a)
+ Haste.DOM: blur :: MonadIO m => Elem -> m ()
+ Haste.DOM: click :: MonadIO m => Elem -> m ()
+ Haste.DOM: documentBody :: Elem
+ Haste.DOM: focus :: MonadIO m => Elem -> m ()
+ Haste.DOM: getFirstChild :: MonadIO m => Elem -> m (Maybe Elem)
+ Haste.Foreign: instance [overlap ok] (Pack a, IOFun b) => IOFun (a -> b)
+ Haste.Foreign: instance [overlap ok] (Unpack a, FFI b) => FFI (a -> b)
+ Haste.Foreign: instance [overlap ok] IOFun (a -> b) => Unpack (a -> b)
+ Haste.Foreign: instance [overlap ok] Pack a => FFI (IO a)
+ Haste.Foreign: instance [overlap ok] Unpack a => IOFun (IO a)
+ Haste.Foreign: instance [overlap ok] Unpack a => Unpack (IO a)
+ Haste.JSON: Null :: JSON
- Haste.Foreign: export :: FFI a => JSString -> a -> IO ()
+ Haste.Foreign: export :: Unpack a => JSString -> a -> IO ()
Files
- LICENSE +1/−1
- Setup.hs +9/−8
- haste-compiler.cabal +55/−58
- lib/Int64.js +3/−3
- lib/rts.js +14/−3
- lib/stdlib.js +21/−3
- libraries/haste-lib/src/Haste/Ajax.hs +13/−5
- libraries/haste-lib/src/Haste/DOM.hs +44/−3
- libraries/haste-lib/src/Haste/Foreign.hs +34/−21
- libraries/haste-lib/src/Haste/JSON.hs +14/−5
- src/ArgSpecs.hs +0/−163
- src/Args.hs +0/−64
- src/Data/JSTarget.hs +1/−1
- src/Data/JSTarget/AST.hs +18/−18
- src/Data/JSTarget/Binary.hs +30/−18
- src/Data/JSTarget/Constructors.hs +22/−36
- src/Data/JSTarget/Optimize.hs +114/−40
- src/Data/JSTarget/PP.hs +5/−0
- src/Data/JSTarget/Print.hs +15/−5
- src/Data/JSTarget/Traversal.hs +18/−4
- src/Haste.hs +2/−2
- src/Haste/Args.hs +95/−0
- src/Haste/Builtins.hs +8/−1
- src/Haste/CodeGen.hs +11/−10
- src/Haste/Config.hs +27/−10
- src/Haste/Environment.hs +96/−62
- src/Haste/Linker.hs +94/−46
- src/Haste/Module.hs +21/−23
- src/Haste/Opts.hs +190/−0
- src/Haste/PrimOps.hs +1/−1
- src/Haste/Version.hs +13/−10
- src/Main.hs +107/−131
- src/haste-boot.hs +73/−54
- src/haste-copy-pkg.hs +9/−4
- src/haste-inst.hs +15/−5
- src/haste-install-his.hs +14/−14
- src/haste-pkg.hs +57/−14
LICENSE view
@@ -1,4 +1,4 @@-Copyright Anton Ekblad 2012-2013+Copyright Anton Ekblad 2012-2014 All rights reserved.
Setup.hs view
@@ -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
haste-compiler.cabal view
@@ -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
lib/Int64.js view
@@ -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();}
lib/rts.js view
@@ -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.
lib/stdlib.js view
@@ -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) {
libraries/haste-lib/src/Haste/Ajax.hs view
@@ -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])
libraries/haste-lib/src/Haste/DOM.hs view
@@ -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"
libraries/haste-lib/src/Haste/Foreign.hs view
@@ -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 =
libraries/haste-lib/src/Haste/JSON.hs view
@@ -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
− src/ArgSpecs.hs
@@ -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 <arg>."},- 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"
− src/Args.hs
@@ -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 ++ "<arg>"- _ -> 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]
src/Data/JSTarget.hs view
@@ -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
src/Data/JSTarget/AST.hs view
@@ -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,
src/Data/JSTarget/Binary.hs view
@@ -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
src/Data/JSTarget/Constructors.hs view
@@ -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
src/Data/JSTarget/Optimize.hs view
@@ -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
src/Data/JSTarget/PP.hs view
@@ -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
src/Data/JSTarget/Print.hs view
@@ -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
src/Data/JSTarget/Traversal.hs view
@@ -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
src/Haste.hs view
@@ -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)
+ src/Haste/Args.hs view
@@ -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]
src/Haste/Builtins.hs view
@@ -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"
src/Haste/CodeGen.hs view
@@ -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
src/Haste/Config.hs view
@@ -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
src/Haste/Environment.hs view
@@ -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"
src/Haste/Linker.hs view
@@ -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'}
src/Haste/Module.hs view
@@ -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
+ src/Haste/Opts.hs view
@@ -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"
src/Haste/PrimOps.hs view
@@ -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"
src/Haste/Version.hs view
@@ -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
src/Main.hs view
@@ -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))
src/haste-boot.hs view
@@ -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] ""
src/haste-copy-pkg.hs view
@@ -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}"
src/haste-inst.hs view
@@ -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
src/haste-install-his.hs view
@@ -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)
src/haste-pkg.hs view
@@ -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"