diff --git a/haste-compiler.cabal b/haste-compiler.cabal --- a/haste-compiler.cabal +++ b/haste-compiler.cabal @@ -1,5 +1,5 @@ Name: haste-compiler -Version: 0.5.1.2 +Version: 0.5.1.3 License: BSD3 License-File: LICENSE Synopsis: Haskell To ECMAScript compiler @@ -10,8 +10,8 @@ OSX. Non-Linux users are strongly recommended to download pre-built - binary packages from http://haste-lang.org/downloads instead - of building from source. + binary packages from haste-lang.org instead of building + from source. Category: JavaScript, Compiler, Web Cabal-Version: >= 1.10 Build-Type: Custom @@ -203,39 +203,6 @@ terminfo if os(windows) c-sources: utils/haste-pkg/CRT_noglob.c - -Executable haste-install-his - if flag(only-library) - buildable: False - Main-Is: haste-install-his.hs - Hs-Source-Dirs: src - if flag(portable) - CPP-Options: -DPORTABLE - Build-Depends: - base < 5, - shellmate, - ghc-paths, - ghc, - directory - default-language: Haskell98 - -Executable haste-copy-pkg - if flag(only-library) - buildable: False - Main-Is: haste-copy-pkg.hs - Other-Modules: - Haste.Environment - Haste.GHCPaths - Hs-Source-Dirs: src - if flag(portable) - CPP-Options: -DPORTABLE - Build-Depends: - base < 5, - shellmate >= 0.1.5, - ghc-paths, - ghc, - directory - default-language: Haskell98 Executable haste-cat if flag(only-library) diff --git a/lib/array.js b/lib/array.js --- a/lib/array.js +++ b/lib/array.js @@ -34,3 +34,4 @@ arr['off'] = 0; return arr; } +window['newByteArr'] = newByteArr; diff --git a/libraries/haste-lib/src/Haste/DOM.hs b/libraries/haste-lib/src/Haste/DOM.hs --- a/libraries/haste-lib/src/Haste/DOM.hs +++ b/libraries/haste-lib/src/Haste/DOM.hs @@ -9,7 +9,7 @@ setChildren, clearChildren, deleteChild, removeChild, -- Own exports PropID, ElemID, QuerySelector, ElemClass, AttrValue, - style, attr, (=:), + prop, style, attr, (=:), newElem, newTextElem, elemById, elemsByQS, elemsByClass, setProp, getProp, setAttr, getAttr, J.getValue, @@ -37,6 +37,11 @@ attr :: String -> AttrName attr = AttrName . toJSStr +-- | Create a DOM property name. +-- See for more information about the difference between attributes and properties. +prop :: String -> AttrName +prop = PropName . toJSStr + -- | Create an 'Attribute'. (=:) :: AttrName -> AttrValue -> Attribute name =: val = attribute name (toJSStr val) @@ -51,27 +56,27 @@ -- | Set a property of the given element. setProp :: (IsElem e, MonadIO m) => e -> PropID -> String -> m () -setProp e prop val = J.setProp e (toJSStr prop) (toJSStr val) +setProp e property val = J.setProp e (toJSStr property) (toJSStr val) -- | Set an attribute of the given element. setAttr :: (IsElem e, MonadIO m) => e -> PropID -> String -> m () -setAttr e prop val = J.setAttr e (toJSStr prop) (toJSStr val) +setAttr e property val = J.setAttr e (toJSStr property) (toJSStr val) -- | Get a property of an element. getProp :: (IsElem e, MonadIO m) => e -> PropID -> m String -getProp e prop = J.getProp e (toJSStr prop) >>= return . fromJSStr +getProp e property = J.getProp e (toJSStr property) >>= return . fromJSStr -- | Get an attribute of an element. getAttr :: (IsElem e, MonadIO m) => e -> PropID -> m String -getAttr e prop = J.getAttr e (toJSStr prop) >>= return . fromJSStr +getAttr e property = J.getAttr e (toJSStr property) >>= return . fromJSStr -- | Get a CSS style property of an element. getStyle :: (IsElem e, MonadIO m) => e -> PropID -> m String -getStyle e prop = J.getStyle e (toJSStr prop) >>= return . fromJSStr +getStyle e property = J.getStyle e (toJSStr property) >>= return . fromJSStr -- | Set a CSS style property on an element. setStyle :: (IsElem e, MonadIO m) => e -> PropID -> String -> m () -setStyle e prop val = J.setStyle e (toJSStr prop) (toJSStr val) +setStyle e property val = J.setStyle e (toJSStr property) (toJSStr val) -- | Get an element by its HTML ID attribute. elemById :: MonadIO m => ElemID -> m (Maybe Elem) diff --git a/libraries/haste-lib/src/Haste/DOM/Core.hs b/libraries/haste-lib/src/Haste/DOM/Core.hs --- a/libraries/haste-lib/src/Haste/DOM/Core.hs +++ b/libraries/haste-lib/src/Haste/DOM/Core.hs @@ -114,10 +114,10 @@ -- | Set a number of 'Attribute's on the element produced by an IO action. -- Gives more convenient syntax when creating elements: -- --- newElem "div" `with` [ --- style "border" =: "1px solid black", --- ... --- ] +-- > newElem "div" `with` [ +-- > style "border" =: "1px solid black", +-- > ... +-- > ] -- with :: (IsElem e, MonadIO m) => m e -> [Attribute] -> m e with m attrs = do @@ -161,8 +161,9 @@ appendChild :: (IsElem parent, IsElem child, MonadIO m) => parent -> child -> m () appendChild parent child = liftIO $ jsAppendChild (elemOf child) (elemOf parent) -{-# DEPRECATED addChild "Use appendChild instead" #-} +{-# DEPRECATED addChild "Use appendChild instead. Note that appendChild == flip addChild." #-} -- | DEPRECATED: use 'appendChild' instead! +-- Note that @appendChild == flip addChild@. addChild :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> m () addChild = flip appendChild @@ -176,8 +177,10 @@ insertChildBefore parent oldChild child = liftIO $ jsAddChildBefore (elemOf child) (elemOf parent) (elemOf oldChild) -{-# DEPRECATED addChildBefore "Use insertChildBefore instead" #-} +{-# DEPRECATED addChildBefore "Use insertChildBefore instead. Note insertChildBefore == \\parent new old -> addChildBefore new parent old." #-} -- | DEPRECATED: use 'insertChildBefore' instead! +-- Note that +-- @insertChildBefore == \parent new old -> addChildBefore new parent old@. addChildBefore :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> child -> m () addChildBefore child parent oldChild = insertChildBefore parent oldChild child @@ -217,10 +220,11 @@ -> m () deleteChild parent child = liftIO $ jsKillChild (elemOf child) (elemOf parent) -{-# DEPRECATED removeChild "Use deleteChild instead" #-} +{-# DEPRECATED removeChild "Use deleteChild instead. Note that deleteChild = flip removeChild." #-} -- | DEPRECATED: use 'deleteChild' instead! +-- Note that @deleteChild = flip removeChild@. removeChild :: (IsElem parent, IsElem child, MonadIO m) => child -> parent -> m () -removeChild child parent = liftIO $ jsKillChild (elemOf child) (elemOf parent) +removeChild = flip deleteChild diff --git a/libraries/haste-lib/src/Haste/DOM/JSString.hs b/libraries/haste-lib/src/Haste/DOM/JSString.hs --- a/libraries/haste-lib/src/Haste/DOM/JSString.hs +++ b/libraries/haste-lib/src/Haste/DOM/JSString.hs @@ -9,7 +9,7 @@ setChildren, clearChildren, deleteChild, removeChild, -- Own exports PropID, ElemID, QuerySelector, ElemClass, AttrValue, - style, attr, (=:), + prop, style, attr, (=:), newElem, newTextElem, elemById, elemsByQS, elemsByClass, setProp, getProp, setAttr, getAttr, getValue, @@ -77,7 +77,13 @@ attr :: JSString -> AttrName attr = AttrName +-- | Create a DOM property name. +-- See for more information about the difference between attributes and properties. +prop :: JSString -> AttrName +prop = PropName + -- | Create an 'Attribute'. +infixl 4 =: (=:) :: AttrName -> AttrValue -> Attribute (=:) = attribute @@ -91,11 +97,11 @@ -- | Set a property of the given element. setProp :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m () -setProp e prop val = liftIO $ jsSet (elemOf e) prop val +setProp e property val = liftIO $ jsSet (elemOf e) property val -- | Set an attribute of the given element. setAttr :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m () -setAttr e prop val = liftIO $ jsSetAttr (elemOf e) prop val +setAttr e property val = liftIO $ jsSetAttr (elemOf e) property val -- | Get the value property of an element; a handy shortcut. getValue :: (IsElem e, MonadIO m, JSType a) => e -> m (Maybe a) @@ -103,19 +109,19 @@ -- | Get a property of an element. getProp :: (IsElem e, MonadIO m) => e -> PropID -> m JSString -getProp e prop = liftIO $ jsGet (elemOf e) prop +getProp e property = liftIO $ jsGet (elemOf e) property -- | Get an attribute of an element. getAttr :: (IsElem e, MonadIO m) => e -> PropID -> m JSString -getAttr e prop = liftIO $ jsGetAttr (elemOf e) prop +getAttr e property = liftIO $ jsGetAttr (elemOf e) property -- | Get a CSS style property of an element. getStyle :: (IsElem e, MonadIO m) => e -> PropID -> m JSString -getStyle e prop = liftIO $ jsGetStyle (elemOf e) prop +getStyle e property = liftIO $ jsGetStyle (elemOf e) property -- | Set a CSS style property on an element. setStyle :: (IsElem e, MonadIO m) => e -> PropID -> JSString -> m () -setStyle e prop val = liftIO $ jsSetStyle (elemOf e) prop val +setStyle e property val = liftIO $ jsSetStyle (elemOf e) property val -- | Get an element by its HTML ID attribute. elemById :: MonadIO m => ElemID -> m (Maybe Elem) diff --git a/libraries/haste-lib/src/Haste/Events.hs b/libraries/haste-lib/src/Haste/Events.hs --- a/libraries/haste-lib/src/Haste/Events.hs +++ b/libraries/haste-lib/src/Haste/Events.hs @@ -1,9 +1,18 @@ -- | Event handling for Haste. module Haste.Events ( - module Core, - module BasicEvents, - module KeyEvents, - module MouseEvents + -- * Core event functionality + Event (..), MonadEvent (..), + HandlerInfo, + unregisterHandler, onEvent, preventDefault, + + -- * Basic events with no arguments + BasicEvent (..), + + -- * Keyboard-related events + KeyEvent (..), KeyData (..), mkKeyData, + + -- * Mouse-related events + MouseEvent (..), MouseData (..), MouseButton (..) ) where import Haste.Events.Core as Core import Haste.Events.BasicEvents as BasicEvents diff --git a/libraries/haste-lib/src/Haste/Random.hs b/libraries/haste-lib/src/Haste/Random.hs --- a/libraries/haste-lib/src/Haste/Random.hs +++ b/libraries/haste-lib/src/Haste/Random.hs @@ -17,16 +17,29 @@ newtype Seed = Seed JSAny deriving (ToAny, FromAny) nxt :: Seed -> IO Seed -nxt = ffi "(function(s){return window['md51'](s.join(','));})" +nxt = ffi "(function(s){\ +var ba = window['newByteArr'](16);\ +ba['v']['w32'][0] = s[0];\ +ba['v']['w32'][1] = s[1];\ +ba['v']['w32'][2] = s[2];\ +ba['v']['w32'][3] = s[3];\ +return window['md51'](ba,16);})" getN :: Seed -> IO Int getN = ffi "(function(s){return s[0];})" toSeed :: Int -> IO Seed -toSeed = ffi "(function(n){return window['md51'](n.toString());})" +toSeed = ffi "(function(n){\ +var ba = window['newByteArr'](16);\ +ba['v']['w32'][0] = n;\ +return window['md51'](ba,16);})" createSeed :: IO Seed -createSeed = ffi "(function(){return window['md51'](jsRand().toString());})" +createSeed = ffi "(function(){\ +var ba = window['newByteArr'](16);\ +ba['v']['f64'][0] = Math.random();\ +ba['v']['f64'][1] = Math.random();\ +return window['md51'](ba,16);})" #else newtype Seed = Seed (Int, SR.StdGen) @@ -47,7 +60,7 @@ mkSeed :: Int -> Seed mkSeed = unsafePerformIO . toSeed --- | Generate a new seed using Javascript's PRNG. +-- | Generate a new seed using JavaScript's PRNG. newSeed :: MonadIO m => m Seed newSeed = liftIO createSeed diff --git a/libraries/haste-prim/src/Haste/Prim/Any.hs b/libraries/haste-prim/src/Haste/Prim/Any.hs --- a/libraries/haste-prim/src/Haste/Prim/Any.hs +++ b/libraries/haste-prim/src/Haste/Prim/Any.hs @@ -103,15 +103,21 @@ -- | Any type that can be converted into a JavaScript value. class ToAny a where -- | Build a JS object from a Haskell value. + -- -- The default instance creates an object from any type that derives -- 'Generic' according to the following rules: + -- -- * Records turn into plain JS objects, with record names as field names. + -- -- * Non-record product types turn into objects containing a @$data@ field -- which contains all of the constructor's unnamed fields. + -- -- * Values of enum types turn into strings matching their constructors. + -- -- * Non-enum types with more than one constructor gain an extra field, -- @$tag@, which contains the name of the constructor used to create the -- object. + -- toAny :: a -> JSAny default toAny :: (GToAny (Rep a), Generic a) => a -> JSAny toAny x = @@ -130,6 +136,8 @@ -- is not possible. Examples of reasonable conversions would be truncating -- floating point numbers to integers, or turning signed integers into -- unsigned. + -- + -- The default instance is the inverse of the default 'ToAny' instance. fromAny :: JSAny -> IO a default fromAny :: (GToAny (Rep a), GFromAny (Rep a), Generic a) => JSAny -> IO a @@ -464,5 +472,3 @@ withSomeException :: IO a -> SomeException -> IO a withSomeException m _ = m - -foreign import ccall "jsLog" dbg :: JSAny -> IO () diff --git a/libraries/haste-prim/src/Haste/Prim/Foreign.hs b/libraries/haste-prim/src/Haste/Prim/Foreign.hs --- a/libraries/haste-prim/src/Haste/Prim/Foreign.hs +++ b/libraries/haste-prim/src/Haste/Prim/Foreign.hs @@ -84,8 +84,9 @@ -- save you from poorly typed JS here, but there are no guarantees. -- -- For instance, the following WILL cause crazy behavior due to wrong types: --- @ffi "(function(x) {return x+1;})" :: Int -> Int -> IO Int@ -- +-- > ffi "(function(x) {return x+1;})" :: Int -> Int -> IO Int +-- -- In other words, this function is as unsafe as the JS it calls on. You -- have been warned. -- @@ -93,7 +94,7 @@ -- in which case evaluation order does not affect the semantics of the -- imported code, or if (b) the imported code is explicitly marked as strict: -- --- someFunction = ffi "__strict(someJSFunction)" +-- > someFunction = ffi "__strict(someJSFunction)" -- -- Literals which depends on some third party initialization, the existence -- of a DOM tree or some other condition which is not fulfilled at load time @@ -125,10 +126,10 @@ #-} -- | Export a symbol. That symbol may then be accessed from JavaScript through --- Haste.name() as a normal function. Remember, however, that if you are +-- @Haste.name()@ as a normal function. Remember, however, that if you are -- using --with-js to include your JS, in conjunction with -- --opt-minify or any option that implies it, you will instead need --- to access your exports through Haste[\'name\'](), or Closure will mangle +-- to access your exports through @Haste[\'name\']()@, or Closure will mangle -- your function names. {-# INLINE export #-} export :: ToAny a => JSString -> a -> IO () diff --git a/src/Haste/Args.hs b/src/Haste/Args.hs --- a/src/Haste/Args.hs +++ b/src/Haste/Args.hs @@ -1,20 +1,21 @@ -module Haste.Args (parseArgs) where +module Haste.Args (parseArgs, printHelp) 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. +-- | Parse a list of command line arguments into a config, a list of args +-- for GHC, and a list of error messages. +-- Non-options are passed directly to GHC. parseArgs :: [OptDescr (a -> a)] -> String -> [String] - -> Either String (a -> a, [String]) + -> Either String (a -> a, [String], [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) + (cfgs, _, errs) = getOpt Permute opts hasteArgs + in Right (foldl' (flip (.)) id cfgs, ghcArgs, errs) -- | Split opts into Haste options and others. splitOpts :: [OptDescr a] -> [String] -> ([String], [String]) @@ -48,18 +49,8 @@ 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) + | opt == "--make" = False + | otherwise = and $ zipWith (==) "--" opt printHelp :: String -> [OptDescr a] -> String printHelp hdr = (hdr ++) . ("\n" ++) . unlines . map helpString diff --git a/src/Haste/Environment.hs b/src/Haste/Environment.hs --- a/src/Haste/Environment.hs +++ b/src/Haste/Environment.hs @@ -6,8 +6,7 @@ hasteGhcLibDir, hostWordSize, ghcPkgBinary, ghcBinary, - hasteBinDir, hasteBinary, hastePkgBinary, hasteInstHisBinary, - hasteCabalBinary, hasteCopyPkgBinary, + hasteBinDir, hasteBinary, hastePkgBinary, hasteCabalBinary, closureCompiler, bootFile, portableHaste, hasteNeedsReboot ) where @@ -131,17 +130,9 @@ hastePkgBinary :: FilePath hastePkgBinary = hasteBinDir "haste-pkg" ++ binaryExt --- | Binary for haste-copy-pkg. -hasteCopyPkgBinary :: FilePath -hasteCopyPkgBinary = hasteBinDir "haste-copy-pkg" ++ binaryExt - -- | Binary for haste-pkg. hasteCabalBinary :: FilePath hasteCabalBinary = hasteBinDir "haste-cabal" ++ binaryExt - --- | Binary for haste-install-his. -hasteInstHisBinary :: FilePath -hasteInstHisBinary = hasteBinDir "haste-install-his" ++ binaryExt -- | JAR for Closure compiler. closureCompiler :: FilePath diff --git a/src/Haste/Opts.hs b/src/Haste/Opts.hs --- a/src/Haste/Opts.hs +++ b/src/Haste/Opts.hs @@ -21,7 +21,7 @@ Option "" ["debug"] (NoArg $ \cfg -> cfg {ppOpts = debugPPOpts (ppOpts cfg)}) $ "Output annotated, pretty-printed JavaScript code. Equivalent to " ++ - "--annotate externals --preserve-names --pretty-print.", + "--annotate-externals --annotate-symbols --pretty-print.", Option "" ["ddisable-js-opts"] (NoArg $ \cfg -> cfg {optimize = False}) $ "Don't perform any optimizations on the JavaScript at all. " ++ @@ -118,7 +118,8 @@ "minification slightly less effective.", Option "" ["preserve-names"] (NoArg $ \cfg -> cfg {ppOpts = withHSNames (ppOpts cfg)}) $ - "Preserve Haskell names in JS code as far as possible.", + "Preserve Haskell names in JavaScript code as far as possible. " ++ + "Highly experimental and may break your code.", Option "" ["pretty-print"] (NoArg $ \cfg -> cfg {ppOpts = withPretty (ppOpts cfg)}) $ "Pretty-print JavaScript output.", @@ -227,4 +228,4 @@ cheap = jsDir "cheap-unicode.js" debugPPOpts :: PPOpts -> PPOpts -debugPPOpts = withPretty . withHSNames . withExtAnnotation +debugPPOpts = withPretty . withAnnotations . withExtAnnotation diff --git a/src/Haste/Version.hs b/src/Haste/Version.hs --- a/src/Haste/Version.hs +++ b/src/Haste/Version.hs @@ -12,7 +12,7 @@ -- | Current Haste version. hasteVersion :: Version -hasteVersion = Version [0,5,1,2] [] +hasteVersion = Version [0,5,1,3] [] -- | Current Haste version as an Int. The format of this version number is -- MAJOR*10 000 + MINOR*100 + MICRO. diff --git a/src/haste-boot.hs b/src/haste-boot.hs --- a/src/haste-boot.hs +++ b/src/haste-boot.hs @@ -5,6 +5,7 @@ import Network.URI import qualified Data.ByteString.Lazy as BS import Data.Version +import Data.List (foldl') import Data.Maybe (fromJust) import Codec.Compression.BZip import Codec.Archive.Tar @@ -160,9 +161,13 @@ main :: IO () main = do args <- getArgs - case parseArgs specs hdr args of - Right (mkConfig, _) -> do - let cfg = mkConfig defCfg + when ("--help" `elem` args || "-?" `elem` args) $ do + putStrLn $ printHelp hdr specs + exitSuccess + + case getOpt Permute specs args of + (cfgs, [], []) -> do + let cfg = foldl' (flip (.)) id cfgs defCfg when (hasteNeedsReboot || forceBoot cfg) $ do res <- shell $ if useLocalLibs cfg then bootHaste cfg "." @@ -170,8 +175,9 @@ case res of Right _ -> return () Left err -> putStrLn err >> exitFailure - Left halp -> do - putStrLn halp + (cfgs, nonopts, errs) -> do + mapM_ putStr errs + mapM_ (\x -> putStrLn $ "unrecognized option `" ++ x ++ "'") nonopts bootHaste :: Cfg -> FilePath -> Shell () bootHaste cfg tmpdir = diff --git a/src/haste-copy-pkg.hs b/src/haste-copy-pkg.hs deleted file mode 100644 --- a/src/haste-copy-pkg.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE CPP #-} --- | haste-copy-pkg; copy a package from file or GHC package DB and fix up its --- paths. -module Main where -import Data.List -import Haste.Environment -import System.Environment (getArgs) -import Control.Shell - -main :: IO () -main = do - args <- getArgs - let (dbs, pkgs) = partition ("--package-db=" `isPrefixOf`) args - pkgdbs = dbs - if null args - then do - putStrLn "Usage: haste-copy-pkg [--package-db=foo.conf] " - else do - res <- shell (mapM_ (copyFromDB pkgdbs) pkgs) - case res of - Left err -> error err - _ -> return () - -copyFromDB :: [String] -> String -> Shell () -copyFromDB pkgdbs package = do - 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 -fixPaths pkgname pkgtext = - pkgtext' - where - pkgtext' = unlines - . map fixPath - . filter (not . ("haddock" `isPrefixOf`)) - . filter (not . ("hs-libraries:" `isPrefixOf`)) - . takeWhile (not . isPrefixOf "---") - $ lines pkgtext - - fixPath str - | isKey "library-dirs:" str = - "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 = - reverse $ drop (length "-inplace") $ reverse str - | otherwise = - str - - isKey _ "" = - False - isKey key str = - and $ zipWith (==) key str - - importDir = "${pkgroot}" - includeDir = "${pkgroot}" "include" - pkgRoot = "${pkgroot}" diff --git a/src/haste-install-his.hs b/src/haste-install-his.hs deleted file mode 100644 --- a/src/haste-install-his.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE TupleSections #-} --- | haste-install-his; install all .hi files in a directory. -module Main where -import Haste.Environment -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] -> shell $ installFromDir (pkgSysLibDir package) dir - _ -> shell $ echo "Usage: haste-install-his pkgname dir" - return () - -getHiFiles :: FilePath -> Shell [FilePath] -getHiFiles dir = - filter (".hi" `isSuffixOf`) <$> ls dir - -getSubdirs :: FilePath -> Shell [FilePath] -getSubdirs dir = do - 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 -> Shell () -installFromDir base path = do - hiFiles <- getHiFiles path - when (not $ null hiFiles) $ do - mkdir True (pkgSysLibDir base) - mapM_ (installHiFile base path) hiFiles - getSubdirs path >>= mapM_ (\d -> installFromDir (base d) (path d)) - -installHiFile :: FilePath -> FilePath -> FilePath -> Shell () -installHiFile to from file = do - echo $ "Installing " ++ from file ++ "..." - cp (from file) (to file) diff --git a/src/hastec.hs b/src/hastec.hs --- a/src/hastec.hs +++ b/src/hastec.hs @@ -197,7 +197,7 @@ _ <- Sh.shell $ Sh.run_ ghcBinary (pkgargs booting ++ ghcArgs) "" return () where - Right (_, ghcArgs) = parseArgs hasteOpts "" args + Right (_, ghcArgs, _) = parseArgs hasteOpts "" args pkgargs booting = ["-no-global-package-db", "-no-user-package-db", @@ -251,17 +251,18 @@ -> Either (IO ()) ([String], Config->Config) parseHasteFlags booting args rawargs = do case runMode booting args of - DontRun msg -> Left $ putStrLn msg - Run GHC -> Left $ callVanillaGHC args - Run Haste -> do - case parseArgs hasteOpts helpHeader args of - Left msg -> Left $ putStrLn msg - Right (cfg, rest) -> Right (filter (/= "-prof") rest, cfg) - Run InstallJSExe -> do - Left $ installJSExe (jsexeIn args) (jsexeOut args) - Run BuildRunner -> do - Left $ callVanillaGHC (rawargs ++ ["-package-id", "Cabal-1.23.0.0-f701f4ea98ec7bed5883c4df743045e6"]) - where + DontRun msg -> Left $ putStrLn msg + Run GHC -> Left $ callVanillaGHC args + Run Haste -> do + case parseArgs hasteOpts helpHeader args of + Left msg -> Left $ putStrLn msg + Right (cfg, rest, []) -> Right (filter (/= "-prof") rest, cfg) + Right (_, _, es) -> Left (mapM_ putStr es >> exitFailure) + Run InstallJSExe -> do + Left $ installJSExe (jsexeIn args) (jsexeOut args) + Run BuildRunner -> do + Left $ callVanillaGHC (rawargs ++ ["-package-id", "Cabal-1.23.0.0-f701f4ea98ec7bed5883c4df743045e6"]) + where jsexeIn ("--install-executable":exe:_) = exe jsexeIn (_:xs) = jsexeIn xs jsexeIn _ = error "No executable to install!"