hpage 0.5.2 → 0.5.3
raw patch · 3 files changed
+65/−35 lines, 3 files
Files
- hpage.cabal +1/−1
- src/HPage/Control.hs +59/−29
- src/HPage/GUI/FreeTextWindow.hs +5/−5
hpage.cabal view
@@ -1,5 +1,5 @@ name: hpage-version: 0.5.2+version: 0.5.3 cabal-version: >=1.6 build-type: Custom license: BSD3
src/HPage/Control.hs view
@@ -74,8 +74,9 @@ import qualified Data.List as List import qualified Data.ByteString.Char8 as Str import qualified Language.Haskell.Exts.Parser as Parser-import Distribution.Simple.Configure+import Distribution.Simple.Configure hiding (tryGetConfigStateFile) import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Utils import Distribution.Package import Distribution.PackageDescription import Distribution.ModuleName@@ -562,37 +563,45 @@ liftErrorIO $ ("Error setting ghc opts dirs", opts, e) return res -loadPackage :: FilePath -> HPage (Either Hint.InterpreterError PackageIdentifier)+loadPackage :: FilePath -> HPage (Either String PackageIdentifier) loadPackage file = do let dir = dropFileName file- lbinfo <- liftIO $ getPersistBuildConfig dir- let pkgdesc = localPkgDescr lbinfo- pkgname = package pkgdesc- bldinfos= allBuildInfo pkgdesc- dirs = ("dist" </> "build" </> "autogen") : (uniq $ concatMap hsSourceDirs bldinfos)- exts = uniq . map (read . show) $ concatMap extensions bldinfos- opts = uniq $ concatMap (hcOptions GHC) bldinfos- mods = uniq . map (joinWith "." . components) $ exeModules pkgdesc ++ (libModules pkgdesc)- action = do- liftTraceIO $ "loading package: " ++ show pkgname- Hint.unsafeSetGhcOption "-i"- Hint.unsafeSetGhcOption "-i."- forM_ dirs $ Hint.unsafeSetGhcOption . ("-i" ++)- Hint.set [Hint.languageExtensions := exts]- forM_ opts $ \opt -> Hint.unsafeSetGhcOption opt `catchError` (\_ -> return ())- return pkgname- liftDebugIO mods- res <- syncRun action+ res <- liftIO $ tryGetPersistBuildConfig dir case res of- Right _ ->- modify (\ctx -> ctx{activePackage = Just pkgname,- pkgModules = mods,- extraSrcDirs = dirs,- ghcOptions = (ghcOptions ctx) ++ " " ++ (joinWith " " opts),- recoveryLog = recoveryLog ctx >> action >> return ()})- Left e ->- liftErrorIO $ ("Error loading package", pkgname, e)- return res+ Left err ->+ return $ Left $ "Couldn't load package: " ++ err+ Right lbinfo ->+ do+ let pkgdesc = localPkgDescr lbinfo+ pkgname = package pkgdesc+ bldinfos= allBuildInfo pkgdesc+ dirs = ("dist" </> "build" </> "autogen") : (uniq $ concatMap hsSourceDirs bldinfos)+ exts = uniq . map (read . show) $ concatMap extensions bldinfos+ opts = uniq $ concatMap (hcOptions GHC) bldinfos+ mods = uniq . map (joinWith "." . components) $ exeModules pkgdesc ++ (libModules pkgdesc)+ action = do+ liftTraceIO $ "loading package: " ++ show pkgname+ Hint.unsafeSetGhcOption "-i"+ Hint.unsafeSetGhcOption "-i."+ forM_ dirs $ Hint.unsafeSetGhcOption . ("-i" ++)+ Hint.set [Hint.languageExtensions := exts]+ forM_ opts $ \opt -> Hint.unsafeSetGhcOption opt `catchError` (\_ -> return ())+ return pkgname+ liftDebugIO mods+ res <- syncRun action+ case res of+ Right x ->+ do+ modify (\ctx -> ctx{activePackage = Just pkgname,+ pkgModules = mods,+ extraSrcDirs = dirs,+ ghcOptions = (ghcOptions ctx) ++ " " ++ (joinWith " " opts),+ recoveryLog = recoveryLog ctx >> action >> return ()})+ return $ Right x+ Left e ->+ do+ liftErrorIO $ ("Error loading package", pkgname, e)+ return . Left $ prettyPrintError e reset :: HPage (Either Hint.InterpreterError ()) reset = do@@ -888,3 +897,24 @@ uniq :: Eq a => [a] -> [a] uniq [] = [] uniq (x:xs) = x : uniq (filter (/= x) xs)++{- Taken from the source code of Distribution.Simple.Configure -}+tryGetPersistBuildConfig :: FilePath -> IO (Either String LocalBuildInfo)+tryGetPersistBuildConfig distPref+ = tryGetConfigStateFile (localBuildInfoFile distPref)++tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a)+tryGetConfigStateFile filename = do+ exists <- doesFileExist filename+ if not exists+ then return (Left missing)+ else withFileContents filename $ \str ->+ case lines str of+ [headder, rest] -> case reads rest of+ [(bi,_)] -> return (Right bi)+ _ -> return (Left cantParse)+ _ -> return (Left cantParse)+ where+ missing = "Run the 'configure' command first."+ cantParse = "Saved package config file seems to be corrupt. "+ ++ "Try re-running the 'configure' command."
src/HPage/GUI/FreeTextWindow.hs view
@@ -503,14 +503,16 @@ return () Just setupConfig -> do- loadres <- tryIn model $ do+ loadres <- tryIn' model $ do lr <- HP.loadPackage setupConfig HP.addPage return lr case loadres of Left err -> warningDialog win "Error" err- Right pkg ->+ Right (Left err) ->+ warningDialog win "Error" err+ Right (Right pkg) -> do absPath <- canonicalizePath setupConfig let dir = joinPath . reverse . drop 2 . reverse $ splitDirectories absPath@@ -850,9 +852,7 @@ res <- HPS.runIn model $ catchError (hpacc >>= return . Right) (\ioerr -> return $ Left ioerr) case res of- Left err -> do- errorIO err- return . Left $ ioeGetErrorString err+ Left err -> return . Left $ ioeGetErrorString err Right (Left err) -> return . Left $ HP.prettyPrintError err Right (Right val) -> return . Right $ val