diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,27 +1,33 @@ import Distribution.MacOSX import Distribution.Simple +import System.Cmd +import System.Exit import System.Directory import System.FilePath +import System.Info (os) import Control.Monad +import Distribution.PackageDescription +import Distribution.Simple.Setup +import Distribution.Simple +import Distribution.Simple.LocalBuildInfo + main :: IO () main = do resources <- getAllDirectoryContents "res" let usefulres = flip filter resources $ \r -> r /= ("res" "images" "icon" "hpage.icns") - putStrLn "Resources: " - forM_ usefulres $ putStrLn . ('\t':) defaultMainWithHooks $ simpleUserHooks { - postBuild = appBundleBuildHook $ guiApps usefulres -- no-op if not MacOS X + postBuild = appBundleBuildHook $ [guiApp usefulres], -- no-op if not MacOS X + postInst = appBundleInstall $ guiApp usefulres } -guiApps :: [FilePath] -> [MacApp] -guiApps rs = [MacApp "hpage" +guiApp :: [FilePath] -> MacApp +guiApp rs = MacApp "hpage" (Just $ "res" "images" "icon" "hpage.icns") Nothing -- Build a default Info.plist for the icon. rs [] -- No other binaries. - ChaseWithDefaults - ] + (ChaseWith $ "libstdc++." : defaultExclusions) getAllDirectoryContents :: FilePath -> IO [FilePath] getAllDirectoryContents p = @@ -34,4 +40,23 @@ then getAllDirectoryContents path else return [path] return $ concat recContents - + +appBundleInstall :: MacApp -> Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO () +appBundleInstall app _ _ pkg localb = + case os of + "darwin" -> + do + ExitSuccess <- copyDirectory appPath theBindir + writeFile scriptFile scriptText + _ -> + return () + where + theBindir = bindir $ absoluteInstallDirs pkg localb NoCopyDest + appPath = buildDir localb appName app <.> "app" + scriptFile = theBindir appName app + finalAppPath = theBindir takeFileName appPath + scriptText = finalAppPath "Contents/MacOS" appName app ++ " \"$@\"" + -- scriptText = "open " ++ finalAppPath + +copyDirectory :: FilePath -> FilePath -> IO ExitCode +copyDirectory dir newLocation = rawSystem "cp" ["-rf", dir, newLocation] diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -1,5 +1,5 @@ name: hpage -version: 0.7.3 +version: 0.7.5 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -47,10 +47,10 @@ eprocess >= 1.1.0, eprocess < 2, hint-server >= 1.1.0, hint-server < 2, time >= 1.1.4, time < 2, - cabal-macosx >= 0.1.0, cabal-macosx < 0.2, + cabal-macosx >= 0.1.1, cabal-macosx < 0.2, FindBin >= 0.0.2, FindBin < 0.1 main-is: Main.hs buildable: True hs-source-dirs: src - other-modules: HPage.GUI.IDs, HPage.GUI.FreeTextWindow, HPage.GUI.Dialogs, HPage.Control, HPage.Server, HPage.Utils.Log, HPage.GUI.Constants, HPage.IOServer + other-modules: HPage.GUI.IDs, HPage.GUI.FreeTextWindow, HPage.GUI.Dialogs, HPage.Control, HPage.Server, HPage.Utils.Log, HPage.GUI.Constants, HPage.IOServer, HPage.GUI.SplashScreen ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns diff --git a/res/images/splash.png b/res/images/splash.png new file mode 100644 Binary files /dev/null and b/res/images/splash.png differ diff --git a/src/HPage/GUI/FreeTextWindow.hs b/src/HPage/GUI/FreeTextWindow.hs --- a/src/HPage/GUI/FreeTextWindow.hs +++ b/src/HPage/GUI/FreeTextWindow.hs @@ -25,6 +25,7 @@ import Graphics.UI.WXCore hiding (kill, Process) import qualified HPage.Control as HP import qualified HPage.Server as HPS +import qualified HPage.GUI.SplashScreen as SS import HPage.GUI.Dialogs import HPage.GUI.IDs import HPage.GUI.Constants @@ -35,7 +36,6 @@ imageFile :: FilePath -> IO FilePath imageFile fp = do progPath <- getProgPath - infoIO progPath path <- case takeBaseName progPath of "MacOS" -> return $ dropFileName progPath "Resources" (takeFileName fp) @@ -92,6 +92,10 @@ set win [on closing := HPS.stop model >> propagateEvent] + ssh <- SS.start win + + SS.step ssh 20 "Starting up..." + -- Containers ntbkL <- notebook win [] pnlPs <- panel ntbkL [] @@ -122,7 +126,7 @@ btnInterpret <- button pnlRes [text := "Interpret"] lblInterpret <- staticText pnlRes [text := "Value:"] lbl4Dots <- staticText pnlRes [text := " :: "] - set pnlRes [layout := fill $ + set pnlRes [layout := fill $ row 5 [widget btnInterpret, centre $ widget lblInterpret, fill $ widget txtValue, @@ -296,30 +300,37 @@ set win [layout := column 5 [fill $ row 10 [leftL, rightL], resultsL], clientSize := sz 800 600] - -- test the server... - runTxtHPSelection "1" model HP.interpret - --HACK: We need to keep a timer ticking just to refresh the screen when the user is doing nothing -- That's because the main C loop of wx only calls wxHaskell callbacks when something happens -- and we try to make things happen in this side but they're not reflected there until some- -- thing happens there timer win [interval := 50, on command := return ()] - + + -- test the server... + SS.step ssh 40 "Preparing model..." + runTxtHPSelection "1" model HP.interpret + + SS.step ssh 60 "Loading first page..." -- ...and RUN! refreshPage model guiCtx + + SS.step ssh 80 "Loading help page..." onCmd "start" openHelpPage - set win [visible := True] + + SS.step ssh 90 "Loading UI..." case args of [] -> return () dir:_ -> do + SS.step ssh 92 "looking for package files..." setupConfig <- canonicalizePath $ dir "dist" "setup-config" pkgExists <- doesFileExist setupConfig case pkgExists of False -> warningDialog win "Error" $ setupConfig ++ " doesn't exist.\n Maybe you have to reconfigure the package" True -> do + SS.step ssh 95 "Loading package..." loadres <- tryIn' model $ do lr <- HP.loadPackage setupConfig HP.addPage @@ -332,8 +343,14 @@ Right (Right pkg) -> do setCurrentDirectory dir + SS.step ssh 97 "warming up..." frameSetTitle win $ "\955Page - " ++ prettyShow pkg + + SS.step ssh 99 "Cleaning UI..." refreshPage model guiCtx + + SS.step ssh 100 "ready" + set win [visible := True] set txtCode [font := fontFixed] -- again just to be sure focusOn txtCode diff --git a/src/HPage/GUI/SplashScreen.hs b/src/HPage/GUI/SplashScreen.hs new file mode 100644 --- /dev/null +++ b/src/HPage/GUI/SplashScreen.hs @@ -0,0 +1,83 @@ + +module HPage.GUI.SplashScreen (start, step, SplashHandle) where + +import Control.Monad +import Control.Monad.Trans +import Control.Concurrent.Process +import Data.Bits +import Graphics.UI.WX hiding (start) +import Graphics.UI.WXCore hiding (kill) +import Graphics.UI.WXCore.WxcDefs +import System.FilePath +import System.Environment.FindBin +import Paths_hpage +import HPage.Utils.Log + +imageFile :: IO FilePath +imageFile = do + progPath <- getProgPath + case takeBaseName progPath of + "MacOS" -> + return $ dropFileName progPath "Resources" "splash.png" + _ -> + getDataFileName $ "res" "images" "splash" <.> "png" + +newtype SplashHandle = SH {handle :: Handle (Int, String)} + +start :: Window a -> IO SplashHandle +start topWin = (spawn $ guiRunner topWin) >>= return . SH + where guiRunner topWin = do + (caption, progress, win) <- liftIO $ gui topWin + forever $ do + myself <- self + (percent, label) <- recv + liftIO $ case percent of + 100 -> + do + debugIO "closing the window" + set win [visible := False] + windowDestroy win + kill myself + _ -> + do + debugIO ("progress", percent, label) + set caption [text := label] + set progress [selection := percent] + wxcAppSafeYield win + return () + +step :: SplashHandle -> Int -> String -> IO () +step sh i s = + do + debugIO ("step", i, s) + sendTo (handle sh) (i,s) + +gui :: Window a -> IO (StaticText (), Gauge (), Frame ()) +gui topWin = + do + let frameStyle = wxSTAY_ON_TOP .&. complement (wxRESIZE_BORDER .|. + wxMAXIMIZE_BOX .|. + wxMINIMIZE_BOX .|. + wxSYSTEM_MENU .|. + wxCLOSE_BOX .|. + wxCAPTION) + win <- frameEx frameStyle [] topWin + timer win [interval := 5, on command := putStr ":"] + + img <- imageFile + htmlw <- htmlWindowCreate win idAny (rect (point 0 0) (sz 870 176)) wxHW_SCROLLBAR_NEVER "" + htmlWindowSetBorders htmlw 0 + htmlWindowSetPage htmlw $ "" + + caption <- staticText win [text := "Loading..."] + + progress <- hgauge win 100 [selection := 0] + + set win [layout := column 0 [hfloatCenter $ widget htmlw, + hfloatCenter $ widget caption, + hfill $ widget progress], + visible := True, + clientSize := sz 870 200] + windowCenter win wxCENTRE_ON_SCREEN + + return (caption, progress, win) diff --git a/src/HPage/Utils/Log.hs b/src/HPage/Utils/Log.hs --- a/src/HPage/Utils/Log.hs +++ b/src/HPage/Utils/Log.hs @@ -17,12 +17,12 @@ traceIO, debugIO, infoIO, warnIO, errorIO, fatalIO :: Show a => a -> IO () liftTraceIO, liftDebugIO, liftInfoIO, liftWarnIO, liftErrorIO, liftFatalIO :: (MonadIO m, Show a) => a -> m () -{- with log... +{- with(out) log... traceIO = logIO Trace -debugIO = logIO Debug +debugIO _ = return () -} traceIO _ = return () -debugIO _ = return () +debugIO = logIO Debug infoIO = logIO Info warnIO = logIO Warning errorIO = logIO Error