hpage 0.7.0 → 0.7.1
raw patch · 6 files changed
+106/−103 lines, 6 filesdep +FindBinsetup-changedbinary-added
Dependencies added: FindBin
Files
- Setup.hs +32/−71
- hpage.cabal +4/−3
- res/images/icon/hPage.icns binary
- res/images/icon/hpage.icns binary
- src/HPage/GUI/FreeTextWindow.hs +68/−28
- src/Main.hs +2/−1
Setup.hs view
@@ -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+
hpage.cabal view
@@ -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
− res/images/icon/hPage.icns
binary file changed (207478 → absent bytes)
+ res/images/icon/hpage.icns view
binary file changed (absent → 32207 bytes)
src/HPage/GUI/FreeTextWindow.hs view
@@ -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
src/Main.hs view
@@ -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 /= '-')