hpage 0.7.3 → 0.7.5
raw patch · 6 files changed
+146/−21 lines, 6 filesdep ~cabal-macosxsetup-changedbinary-added
Dependency ranges changed: cabal-macosx
Files
- Setup.hs +33/−8
- hpage.cabal +3/−3
- res/images/splash.png binary
- src/HPage/GUI/FreeTextWindow.hs +24/−7
- src/HPage/GUI/SplashScreen.hs +83/−0
- src/HPage/Utils/Log.hs +3/−3
Setup.hs view
@@ -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]
hpage.cabal view
@@ -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
+ res/images/splash.png view
binary file changed (absent → 17347 bytes)
src/HPage/GUI/FreeTextWindow.hs view
@@ -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
+ src/HPage/GUI/SplashScreen.hs view
@@ -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 $ "<img src='file://" ++ img ++ "' />"+ + 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)
src/HPage/Utils/Log.hs view
@@ -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