diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,76 +1,37 @@ -{-# LANGUAGE CPP #-} - -import Control.Monad (foldM_, forM_) -import System.Cmd -import System.Exit -import System.Info (os) -import System.FilePath -import System.Directory ( doesFileExist, copyFile, removeFile, createDirectoryIfMissing ) - -import Distribution.PackageDescription -import Distribution.Simple.Setup +import Distribution.MacOSX import Distribution.Simple -import Distribution.Simple.LocalBuildInfo +import System.Directory +import System.FilePath +import Control.Monad main :: IO () main = do - putStrLn $ "Setting up hpage for " ++ os - defaultMainWithHooks $ addMacHook simpleUserHooks - where - addMacHook h = - case os of - "darwin" -> h { postInst = appBundleHook, - runTests = hPageTestRunner } - _ -> h { runTests = hPageTestRunner } - -appBundleHook :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO () -appBundleHook _ _ pkg localb = - forM_ exes $ \app -> - do createAppBundle theBindir (buildDir localb app app) - removeFile (theBindir app) - createAppBundleWrapper theBindir app - return () - where - theBindir = bindir $ absoluteInstallDirs pkg localb NoCopyDest - exes = map exeName $ executables pkg - --- ---------------------------------------------------------------------- --- helper code for application bundles --- ---------------------------------------------------------------------- - --- | 'createAppBundle' @d p@ - creates an application bundle in @d@ --- for program @p@, assuming that @d@ already exists and is a directory. --- Note that only the filename part of @p@ is used. -createAppBundle :: FilePath -> FilePath -> IO () -createAppBundle dir p = - do createDirectoryIfMissing False $ bundle - createDirectoryIfMissing True $ bundleBin - createDirectoryIfMissing True $ bundleRsrc - copyFile p (bundleBin takeFileName p) - where - bundle = appBundlePath dir p - bundleBin = bundle "Contents/MacOS" - bundleRsrc = bundle "Contents/Resources" - --- | 'createAppBundleWrapper' @d p@ - creates a script in @d@ that calls --- @p@ from the application bundle @d takeFileName p <.> "app"@ -createAppBundleWrapper :: FilePath -> FilePath -> IO ExitCode -createAppBundleWrapper bindir p = - do writeFile scriptFile scriptTxt - makeExecutable scriptFile - where - scriptFile = bindir takeFileName p - scriptTxt = "`dirname $0`" appBundlePath "." p "Contents/MacOS" takeFileName p ++ " \"$@\"" - -appBundlePath :: FilePath -> FilePath -> FilePath -appBundlePath dir p = dir takeFileName p <.> "app" - --- ---------------------------------------------------------------------- --- utilities --- ---------------------------------------------------------------------- - -makeExecutable :: FilePath -> IO ExitCode -makeExecutable f = system $ "chmod a+x " ++ f + 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 + } -hPageTestRunner :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () -hPageTestRunner _ _ _ _ = system "runhaskell -isrc -idist/build/autogen HPage.Test.Server" >> return () +guiApps :: [FilePath] -> [MacApp] +guiApps rs = [MacApp "hpage" + (Just $ "res" "images" "icon" "hpage.icns") + Nothing -- Build a default Info.plist for the icon. + rs + [] -- No other binaries. + ChaseWithDefaults + ] + +getAllDirectoryContents :: FilePath -> IO [FilePath] +getAllDirectoryContents p = + do + allContents <- getDirectoryContents p + let nonHidden = map (\path -> p path) $ flip filter allContents $ \path -> head path /= '.' + recContents <- forM nonHidden $ \path -> do + exists <- doesDirectoryExist path + if exists + then getAllDirectoryContents path + else return [path] + return $ concat recContents + diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -1,5 +1,5 @@ name: hpage -version: 0.7.0 +version: 0.7.1 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -18,7 +18,7 @@ data-files: LICENSE README res/images/*.png res/images/*.ico - res/images/icon/hPage.icns + res/images/icon/hpage.icns res/images/icon/hpage.tif res/help/helpPage.hs res/test/*.hs @@ -46,7 +46,8 @@ hint >= 0.3.2, hint < 0.4, eprocess >= 1.1.0, eprocess < 2, hint-server >= 1.1.0, hint-server < 2, - time >= 1.1.4, time < 2 + time >= 1.1.4, time < 2, + FindBin >= 0.0.2, FindBin < 0.1 main-is: Main.hs buildable: True hs-source-dirs: src diff --git a/res/images/icon/hPage.icns b/res/images/icon/hPage.icns deleted file mode 100644 Binary files a/res/images/icon/hPage.icns and /dev/null differ diff --git a/res/images/icon/hpage.icns b/res/images/icon/hpage.icns new file mode 100644 Binary files /dev/null and b/res/images/icon/hpage.icns 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 @@ -29,12 +29,18 @@ import HPage.GUI.IDs import HPage.GUI.Constants import HPage.Utils.Log - -import Paths_hpage -- cabal locations of data files +import System.Environment.FindBin +import Paths_hpage imageFile :: FilePath -> IO FilePath imageFile fp = do - path <- getDataFileName $ "res/images/" ++ fp + progPath <- getProgPath + infoIO progPath + path <- case takeBaseName progPath of + "MacOS" -> + return $ dropFileName progPath "Resources" (takeFileName fp) + _ -> + getDataFileName $ "res/images/" ++ fp real <- doesFileExist path if real then return path else do @@ -42,7 +48,14 @@ fail (path ++ " does not exist") helpFile :: IO FilePath -helpFile = getDataFileName "res/help/helpPage.hs" +helpFile = + do + progPath <- getProgPath + case takeBaseName progPath of + "MacOS" -> + return $ dropFileName progPath "Resources" "helpPage.hs" + _ -> + getDataFileName "res/help/helpPage.hs" data GUIBottom = GUIBtm { bottomDesc :: String, bottomSource :: String } @@ -67,8 +80,8 @@ guiChrFiller :: MVar (Handle String), guiValFiller :: MVar (Handle (String, IO ()))} -gui :: IO () -gui = +gui :: [String] -> IO () +gui args = do -- Server context model <- HPS.start @@ -296,6 +309,31 @@ refreshPage model guiCtx onCmd "start" openHelpPage set win [visible := True] + case args of + [] -> + return () + dir:_ -> + do + 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 + loadres <- tryIn' model $ do + lr <- HP.loadPackage setupConfig + HP.addPage + return lr + case loadres of + Left err -> + warningDialog win "Error" err + Right (Left err) -> + warningDialog win "Error" err + Right (Right pkg) -> + do + setCurrentDirectory dir + frameSetTitle win $ "\955Page - " ++ prettyShow pkg + refreshPage model guiCtx set txtCode [font := fontFixed] -- again just to be sure focusOn txtCode @@ -649,28 +687,26 @@ res <- fileOpenDialog win True True "Select the setup-config file for your project..." [("setup-config",["setup-config"])] startDir "setup-config" case res of - Nothing -> - return () - Just setupConfig -> - do - loadres <- tryIn' model $ do - lr <- HP.loadPackage setupConfig - HP.addPage - return lr - case loadres of - Left err -> - warningDialog win "Error" err - Right (Left err) -> - warningDialog win "Error" err - Right (Right pkg) -> - do - absPath <- canonicalizePath setupConfig - let dir = joinPath . reverse . drop 2 . reverse $ splitDirectories absPath - setCurrentDirectory dir - frameSetTitle win $ "\955Page - " ++ prettyShow pkg - refreshPage model guiCtx - where prettyShow PackageIdentifier{pkgName = PackageName pkgname, - pkgVersion = pkgvsn} = pkgname ++ "-" ++ showVersion pkgvsn + Nothing -> + return () + Just setupConfig -> + do + loadres <- tryIn' model $ do + lr <- HP.loadPackage setupConfig + HP.addPage + return lr + case loadres of + Left err -> + warningDialog win "Error" err + Right (Left err) -> + warningDialog win "Error" err + Right (Right pkg) -> + do + absPath <- canonicalizePath setupConfig + let dir = joinPath . reverse . drop 2 . reverse $ splitDirectories absPath + setCurrentDirectory dir + frameSetTitle win $ "\955Page - " ++ prettyShow pkg + refreshPage model guiCtx loadModules model guiCtx@GUICtx{guiWin = win, guiStatus = status} = do @@ -1110,3 +1146,7 @@ indexOf :: String -> String -> Maybe Int indexOf substring string = findIndex (isPrefixOf substring) $ tails string + +prettyShow :: PackageIdentifier -> String +prettyShow PackageIdentifier{pkgName = PackageName pkgname, + pkgVersion = pkgvsn} = pkgname ++ "-" ++ showVersion pkgvsn diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -2,6 +2,7 @@ import Graphics.UI.WX import HPage.GUI.FreeTextWindow +import System.Environment main :: IO () -main = start gui +main = getArgs >>= start . gui . filter (\arg -> head arg /= '-')