diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -10,6 +10,7 @@ import Distribution.PackageDescription import Distribution.Simple.Setup import Distribution.Simple +import Distribution.Simple.Utils import Distribution.Simple.LocalBuildInfo main :: IO () @@ -18,7 +19,8 @@ let usefulres = flip filter resources $ \r -> r /= ("res" "images" "icon" "hpage.icns") defaultMainWithHooks $ simpleUserHooks { postBuild = appBundleBuildHook $ [guiApp usefulres], -- no-op if not MacOS X - postInst = appBundleInstall $ guiApp usefulres + postInst = appBundleInstall $ guiApp usefulres, + runTests = runTests' } guiApp :: [FilePath] -> MacApp @@ -60,3 +62,10 @@ copyDirectory :: FilePath -> FilePath -> IO ExitCode copyDirectory dir newLocation = rawSystem "cp" ["-rf", dir, newLocation] + +runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () +runTests' _ _ _ lbi = do + built <- doesDirectoryExist $ buildDir lbi + unless built $ die "Run the 'build' command first." + system $ "cd src && runhaskell -i../dist/build/autogen HPage.Test.Server && cd .." + return () diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -1,5 +1,5 @@ name: hpage -version: 0.11.1 +version: 0.12.0 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -34,26 +34,25 @@ Executable hpage build-depends: base >= 4, base < 5, - mtl >= 1.1.0.2, mtl < 2, - bytestring >= 0.9.1, bytestring < 0.10, - Cabal >= 1.8.0.2, Cabal < 1.9, - cabal-macosx >= 0.1.0, cabal-macosx < 0.2, FindBin >= 0.0.2, FindBin < 0.1, - time >= 1.1.4, time < 2, - hint >= 0.3.2, hint < 0.4, - eprocess >= 1.1.2, eprocess < 2, - hint-server >= 1.2.0, hint-server < 2, wxcore >= 0.12.1.4, wxcore < 0.13, wx >= 0.12.1.4, wx < 0.13, - haskell-src-exts >= 1.9.0, haskell-src-exts < 2, monad-loops >= 0.3.0, monad-loops < 0.4, + process >= 1.0.1.2, process < 1.1, + time >= 1.1.4, time < 1.2, + mtl >= 1.1.0.2, mtl < 1.2, + Cabal >= 1.8.0.2, Cabal < 1.9, + haskell-src-exts >= 1.9.0, haskell-src-exts < 2, + bytestring >= 0.9.1.5, bytestring < 0.9.2, containers >= 0.3.0.0, containers < 0.4, filepath >= 1.1.0.3, filepath < 1.2, - directory >= 1.0.1, directory < 1.1, - process >= 1.0.1.2, process < 1.1, - MonadCatchIO-mtl >= 0.1.0, MonadCatchIO-mtl < 0.4 + directory >= 1.0.1.0, directory < 1.1, + hint >= 0.3.2.3, hint < 0.4, + hint-server >= 1.2.0, hint-server < 1.3, + eprocess >= 1.1.2, eprocess < 2 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, HPage.GUI.SplashScreen + other-modules: HPage.GUI.IDs, HPage.GUI.FreeTextWindow, HPage.GUI.Dialogs, + HPage.Utils.Log, HPage.GUI.Constants, HPage.GUI.SplashScreen ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns diff --git a/src/HPage/Control.hs b/src/HPage/Control.hs deleted file mode 100644 --- a/src/HPage/Control.hs +++ /dev/null @@ -1,1024 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, - MultiParamTypeClasses, - FlexibleInstances, - FunctionalDependencies, - TypeSynonymInstances, - UndecidableInstances #-} -module HPage.Control ( - -- MONAD CONTROLS -- - HPage, evalHPage, - -- PAGE CONTROLS -- - getPageIndex, setPageIndex, getPageCount, - addPage, openPage, closePage, closeAllPages, getPagePath, - savePage, savePageAs, - isModifiedPage, isModifiedPageNth, - closePageNth, getPageNthPath, - savePageNth, savePageNthAs, - PageDescription(..), getPageDesc, getPageNthDesc, - -- SAFE PAGE CONTROLS -- - safeClosePage, safeCloseAllPages, - safeSavePageAs, safeClosePageNth, - safeSavePageNthAs, - -- EXPRESSION CONTROLS -- - setPageText, getPageText, clearPage, - getExprIndex, setExprIndex, getExprCount, - addExpr, removeExpr, - setExprText, getExprText, - removeNth, - setExprNthText, getExprNthText, - -- EDITION CONTROLS -- - undo, redo, - -- HINT CONTROLS -- - interpret, interpretNth, Interpretation, intKind, intValue, intValues, - intType, isIntType, isIntExprs, - valueOf, valueOfNth, kindOf, kindOfNth, typeOf, typeOfNth, - loadModules, - reloadModules, getLoadedModules, - importModules, getImportedModules, - getPackageModules, - getModuleExports, - getLanguageExtensions, setLanguageExtensions, - getSourceDirs, setSourceDirs, - getGhcOpts, setGhcOpts, - loadPackage, - loadModules', - reloadModules', getLoadedModules', importModules', getImportedModules', - getModuleExports', - getLanguageExtensions', setLanguageExtensions', - getSourceDirs', setSourceDirs', - getGhcOpts', setGhcOpts', - reset, reset', - cancel, - Hint.InterpreterError, prettyPrintError, - Hint.availableExtensions, Hint.Extension(..), - ModuleDescription(..), ModuleElemDesc(..), - -- DEBUG -- - ctxString - ) where - -import System.Directory -import System.FilePath -import Data.Set (Set, empty, union, fromList, toList) -import Control.Monad.Loops -import Control.Monad.Error -import Control.Monad.State -import Control.Concurrent.MVar -import Language.Haskell.Interpreter (OptionVal((:=))) -import qualified Language.Haskell.Interpreter as Hint -import qualified Language.Haskell.Interpreter.Unsafe as Hint -import qualified Language.Haskell.Interpreter.Server as HS -import HPage.Utils.Log -import Data.List (isPrefixOf) -import qualified Data.ByteString.Char8 as Str -import qualified Language.Haskell.Exts as Xs -import Distribution.Simple.Configure hiding (tryGetConfigStateFile) -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Utils -import Distribution.Package -import Distribution.PackageDescription -import Distribution.ModuleName -import Distribution.Compiler -import qualified HPage.IOServer as HPIO - -data Interpretation = Type {intKind :: String} | - Expr {intValue :: String, intType :: String} | - Exprs {intValues :: [String], intType :: String} - deriving (Eq, Show) - -isIntType :: Interpretation -> Bool -isIntType Type{} = True -isIntType Expr{} = False -isIntType Exprs{} = False - -isIntExprs :: Interpretation -> Bool -isIntExprs Type{} = False -isIntExprs Expr{} = False -isIntExprs Exprs{} = True - -data ModuleDescription = ModDesc {modName :: String, - modInterpreted :: Bool} - deriving (Eq) - -instance Show ModuleDescription where - show m = show (modName m, modInterpreted m) - -data ModuleElemDesc = MEFun {funName :: String, - funType :: String} | - MEClass {clsName :: String, - clsFuns :: [ModuleElemDesc]} | - MEData {datName :: String, - datCtors :: [ModuleElemDesc]} - deriving (Eq) - -instance Show ModuleElemDesc where - show MEFun{funName = fn, funType = []} = fn - show MEFun{funName = fn, funType = ft} = fn ++ " :: " ++ ft - show MEClass{clsName = cn, clsFuns = []} = "class " ++ cn - show MEClass{clsName = cn, clsFuns = cfs} = "class " ++ cn ++ " where " ++ joinWith "\n" (map show cfs) - show MEData{datName = dn, datCtors = []} = "data " ++ dn - show MEData{datName = dn, datCtors = dcs} = "data " ++ dn ++ " = " ++ joinWith " | " (map show dcs) - -data PageDescription = PageDesc {pIndex :: Int, - pPath :: Maybe FilePath, - pIsModified :: Bool} - deriving (Eq, Show) - -newtype Expression = Exp {exprText :: String} - deriving (Eq, Show) - -data InFlightData = LoadModules { loadingModules :: Set String, - runningAction :: Hint.InterpreterT IO () - } | - ImportModules { importingModules :: Set String, - runningAction :: Hint.InterpreterT IO () - } | - SetSourceDirs { settingSrcDirs :: [FilePath], - runningAction :: Hint.InterpreterT IO () - } | - SetGhcOpts { settingGhcOpts :: String, - runningAction :: Hint.InterpreterT IO () - } | - Reset - -data Page = Page { -- Display -- - expressions :: [Expression], - currentExpr :: Int, - undoActions :: [HPage ()], - redoActions :: [HPage ()], - original :: [Expression], - -- File System -- - filePath :: Maybe FilePath - } - -instance Show Page where - show p = "Text: " ++ (showExpressions p) ++ - "\nFile: " ++ show (filePath p) - where showExpressions pg = showWithCurrent (expressions pg) (currentExpr pg) "\n\n" $ ("["++) . (++"]") - -data Context = Context { -- Package -- - activePackage :: Maybe PackageIdentifier, - pkgModules :: [Hint.ModuleName], - -- Pages -- - pages :: [Page], - currentPage :: Int, - -- Hint -- - loadedModules :: Set String, - importedModules :: Set String, - extraSrcDirs :: [FilePath], - ghcOptions :: String, - server :: HS.ServerHandle, - running :: Maybe InFlightData, - recoveryLog :: Hint.InterpreterT IO (), -- To allow cancelation of actions - -- IO Server -- - ioServer :: HPIO.ServerHandle - } - -instance Show Context where - show c = showWithCurrent (pages c) (currentPage c) sep $ (top++) . (++bottom) - where sep = "\n" ++ replicate 80 '-' ++ "\n" - top = replicate 80 'v' ++ "\n" - bottom = "\n" ++ replicate 80 '^' - -newtype HPageT m a = HPT { state :: StateT Context m a } - deriving (Monad, MonadIO, MonadTrans) - -instance Monad m => MonadState Context (HPageT m) where - get = HPT $ get - put = HPT . put - -instance MonadError e m => MonadError e (HPageT m) where - throwError = lift . throwError - catchError (HPT a) h = HPT $ a `catchError` (\e -> state $ h e) - -type Extension = Hint.Extension - -instance Ord Extension where - e1 `compare` e2 = (show e1) `compare` (show e2) - -type HPage = HPageT IO - -evalHPage :: HPage a -> IO a -evalHPage hpt = do - hs <- liftIO $ HS.start - hpios <- liftIO $ HPIO.start - let nop = return () - let emptyContext = Context Nothing [] [emptyPage] 0 empty (fromList ["Prelude"]) [] "" hs Nothing nop hpios - (state hpt) `evalStateT` emptyContext - - -ctxString :: HPage String -ctxString = get >>= return . show - -addPage :: HPage () -addPage = modify (\ctx -> ctx{pages = emptyPage:(pages ctx), - currentPage = 0}) - -openPage :: FilePath -> HPage () -openPage file = do - liftTraceIO $ "opening: " ++ file - s <- liftIO $ Str.readFile file - let str = Str.unpack s - let (newExprs, curExpr) = exprFromString' str $ length str - newPage = emptyPage{expressions = newExprs, - currentExpr = curExpr, - filePath = Just file, - original = newExprs} - modify (\ctx -> ctx{pages = newPage : pages ctx, - currentPage = 0}) - -savePage :: HPage () -savePage = get >>= savePageNth . currentPage - -savePageNth :: Int -> HPage () -savePageNth i = do - page <- getPageNth i - case filePath page of - Nothing -> - fail "No place to save" - Just file -> - savePageNthAs i file - -savePageAs :: FilePath -> HPage () -savePageAs file = get >>= (flip savePageNthAs) file . currentPage - -savePageNthAs :: Int -> FilePath -> HPage () -savePageNthAs i file = do - p <- getPageNth i - liftTraceIO $ "writing: " ++ file - liftIO $ Str.writeFile file $ Str.pack $ toString p - modifyPageNth i (\page -> page{filePath = Just file, - original = (expressions page)}) - -isModifiedPage :: HPage Bool -isModifiedPage = get >>= isModifiedPageNth . currentPage - -isModifiedPageNth :: Int -> HPage Bool -isModifiedPageNth i = withPageIndex i $ do - page <- getPageNth i - return $ expressions page /= original page - -getPagePath :: HPage (Maybe FilePath) -getPagePath = get >>= getPageNthPath . currentPage - -getPageNthPath :: Int -> HPage (Maybe FilePath) -getPageNthPath i = getPageNth i >>= return . filePath - -getPageCount :: HPage Int -getPageCount = get >>= return . length . pages - -getPageIndex :: HPage Int -getPageIndex = get >>= return . currentPage - -setPageIndex :: Int -> HPage () -setPageIndex (-1) = modify (\ctx -> ctx{currentPage = (-1)}) -setPageIndex i = withPageIndex i $ modify (\ctx -> ctx{currentPage = i}) - -getPageDesc :: HPage PageDescription -getPageDesc = get >>= getPageNthDesc . currentPage - -getPageNthDesc :: Int -> HPage PageDescription -getPageNthDesc i = do - p <- getPageNthPath i - m <- isModifiedPageNth i - return $ PageDesc i p m - -closePage :: HPage () -closePage = get >>= closePageNth . currentPage - -closePageNth :: Int -> HPage () -closePageNth i = withPageIndex i $ do - count <- getPageCount - case count of - 1 -> - closeAllPages - _ -> - modify (\c -> c{pages = insertAt i [] $ pages c, - currentPage = if i == currentPage c - then case i of - 0 -> 0 - _ -> i - 1 - else currentPage c}) - -closeAllPages :: HPage () -closeAllPages = modify (\ctx -> ctx{pages = [emptyPage], - currentPage = 0}) - -safeClosePage :: HPage () -safeClosePage = get >>= safeClosePageNth . currentPage - -safeCloseAllPages :: HPage () -safeCloseAllPages = do - ps <- liftM (length . pages) $ get - ms <- anyM isModifiedPageNth [0..ps-1] - if ms then fail "There are modified pages" - else closeAllPages - -safeClosePageNth :: Int -> HPage () -safeClosePageNth i = do - m <- isModifiedPageNth i - if m then fail "The page is modified" - else closePageNth i - -safeSavePageAs :: FilePath -> HPage () -safeSavePageAs file = get >>= (flip safeSavePageNthAs) file . currentPage - -safeSavePageNthAs :: Int -> FilePath -> HPage () -safeSavePageNthAs i file = do - m <- liftIO $ doesFileExist file - if m then fail "The page is modified" - else savePageNthAs i file - -clearPage :: HPage () -clearPage = setPageText "" 0 >> return () - -setPageText :: String -> Int -> HPage Bool -setPageText s ip = - do - let (exprs, ix) = exprFromString' s ip - page <- getPage - if exprs /= expressions page || ix /= currentExpr page - then - do - modifyWithUndo (\p -> p{expressions = exprs, - currentExpr = ix}) - return True - else - return False - -getPageText :: HPage String -getPageText = getPage >>= return . toString - -getExprIndex :: HPage Int -getExprIndex = getPage >>= return . currentExpr - -setExprIndex :: Int -> HPage () -setExprIndex (-1) = modifyWithUndo (\p -> p{currentExpr = -1}) -setExprIndex nth = withExprIndex nth $ modifyWithUndo (\p -> p{currentExpr = nth}) - -getExprCount :: HPage Int -getExprCount = getPage >>= return . length . expressions - -getExprText :: HPage String -getExprText = getPage >>= getExprNthText . currentExpr - -setExprText :: String -> HPage () -setExprText expr = getPage >>= flip setExprNthText expr . currentExpr - -getExprNthText :: Int -> HPage String -getExprNthText nth = withExprIndex nth $ getPage >>= return . exprText . (!! nth) . expressions - -setExprNthText :: Int -> String -> HPage () -setExprNthText nth expr = withExprIndex nth $ - do - page <- getPage - liftTraceIO ("setExprNthText",nth,expr,expressions page, currentExpr page) - modifyWithUndo (\p -> - let newExprs = insertAt nth (exprFromString expr) $ expressions p - curExpr = currentExpr p - in p{expressions = newExprs, - currentExpr = if curExpr < length newExprs then - curExpr else - length newExprs -1}) - -addExpr :: String -> HPage () -addExpr expr = do - p <- getPage - liftTraceIO ("addExpr",expr,expressions p, currentExpr p) - modifyWithUndo (\page -> - let exprs = expressions page - newExprs = insertAt (length exprs) (exprFromString expr) exprs - in page{expressions = newExprs, - currentExpr = length newExprs - 1}) - -removeExpr :: HPage () -removeExpr = getPage >>= removeNth . currentExpr - -removeNth :: Int -> HPage () -removeNth i = setExprNthText i "" - -undo, redo :: HPage () -undo = do - p <- getPage - case undoActions p of - [] -> - liftTraceIO ("not undo", expressions p) - -- return () - (acc:accs) -> - do - acc - getPage >>= (\px -> liftTraceIO ("redo added", expressions p, expressions px)) - modifyPage (\page -> - let redoAct = modifyPage (\pp -> pp{expressions = expressions p, - currentExpr = currentExpr p}) - in page{redoActions = redoAct : redoActions page, - undoActions = accs}) -redo = do - p <- getPage - case redoActions p of - [] -> - liftTraceIO ("not redo", expressions p) - -- return () - (acc:accs) -> - do - acc - getPage >>= (\px -> liftTraceIO ("undo added", expressions px, expressions p)) - modifyPage (\page -> - let undoAct = modifyPage (\pp -> pp{expressions = expressions p, - currentExpr = currentExpr p}) - in page{undoActions = undoAct : undoActions page, - redoActions = accs}) - -interpret :: HPage (Either Hint.InterpreterError Interpretation) -interpret = getPage >>= interpretNth . currentExpr - -valueOf, kindOf, typeOf :: HPage (Either Hint.InterpreterError String) -valueOf = getPage >>= valueOfNth . currentExpr -kindOf = getPage >>= kindOfNth . currentExpr -typeOf = getPage >>= typeOfNth . currentExpr - -interpretNth :: Int -> HPage (Either Hint.InterpreterError Interpretation) -interpretNth i = - do - liftDebugIO ("Interpreting", i) - typeRes <- typeOfNth i - case typeRes of - Left terr -> - do - kindRes <- kindOfNth i - case kindRes of - Left _ -> return $ Left terr - Right k -> return . Right $ Type{intKind = k} - Right t -> - do - if isIO t - then do - valueRes <- getIOFromExprNth i - case valueRes of - Right ioAction -> - do - ctx <- get - iores <- liftIO $ HPIO.runIn (ioServer ctx) ioAction - case iores of - Left err -> - return . Left . Hint.UnknownError $ show err - Right r -> - return . Right $ Expr{intValue = r, intType = t} - Left err -> - return $ Left err - else if isList t - then do - liftDebugIO "interpreting a list" - valueRes <- getListFromExprNth i - case valueRes of - Left verr -> - if isNotShowable verr - then return $ Right $ Expr{intValue = "", intType = t} - else return $ Left verr - Right list -> return . Right $ Exprs{intValues = list, intType = t} - else do - liftDebugIO "interpreting a value" - valueRes <- valueOfNth i - case valueRes of - Left verr -> - if isNotShowable verr - then return $ Right $ Expr{intValue = "", intType = t} - else return $ Left verr - Right v -> return $ Right $ Expr{intValue = v, intType = t} - where isNotShowable (Hint.WontCompile ghcerrs) = any complainsAboutShow ghcerrs - isNotShowable _ = False - complainsAboutShow err = let errMsg = Hint.errMsg err - in "No instance for (GHC.Show" `isPrefixOf` errMsg - -valueOfNth, kindOfNth, typeOfNth :: Int -> HPage (Either Hint.InterpreterError String) -valueOfNth i = runInExprNthWithLets Hint.eval i -kindOfNth = runInExprNth Hint.kindOf -typeOfNth = runInExprNthWithLets Hint.typeOf - -loadModules :: [String] -> HPage (Either Hint.InterpreterError ()) -loadModules ms = do - let action = do - liftTraceIO $ "loading: " ++ show ms - Hint.loadModules ms - Hint.getLoadedModules >>= Hint.setTopLevelModules - res <- syncRun action - case res of - Right _ -> - modify (\ctx -> ctx{loadedModules = union (fromList ms) (loadedModules ctx), - recoveryLog = recoveryLog ctx >> action >> return ()}) - Left e -> - liftErrorIO $ ("Error loading modules", ms, e) - return res - -importModules :: [String] -> HPage (Either Hint.InterpreterError ()) -importModules newms = do - ctx <- confirmRunning - let ms = toList $ importedModules ctx - action = do - liftTraceIO $ "importing: " ++ show newms - Hint.setImports $ ms ++ newms - res <- syncRun action - case res of - Right _ -> - modify (\c -> c{importedModules = union (fromList newms) (importedModules c), - recoveryLog = recoveryLog c >> action >> return ()}) - Left e -> - liftErrorIO $ ("Error importing modules", ms, e) - return res - -reloadModules :: HPage (Either Hint.InterpreterError ()) -reloadModules = do - ctx <- confirmRunning - let ms = toList $ loadedModules ctx - syncRun $ do - liftTraceIO $ "reloading: " ++ (show ms) - Hint.loadModules ms - Hint.getLoadedModules >>= Hint.setTopLevelModules - -getLoadedModules :: HPage (Either Hint.InterpreterError [ModuleDescription]) -getLoadedModules = do - confirmRunning_ - syncRun $ do - mns <- Hint.getLoadedModules - mis <- mapM Hint.isModuleInterpreted mns - return $ zipWith ModDesc mns mis - -getImportedModules :: HPage [Hint.ModuleName] -getImportedModules = confirmRunning >>= return . toList . importedModules - -getPackageModules :: HPage [Hint.ModuleName] -getPackageModules = confirmRunning >>= return . pkgModules - -getModuleExports :: Hint.ModuleName -> HPage (Either Hint.InterpreterError [ModuleElemDesc]) -getModuleExports mn = do - confirmRunning_ - let action = do - exs <- Hint.getModuleExports mn - mapM moduleElemDesc exs - syncRun action - -getLanguageExtensions :: HPage (Either Hint.InterpreterError [Hint.Extension]) -getLanguageExtensions = confirmRunning >> syncRun (Hint.get Hint.languageExtensions) - -setLanguageExtensions :: [Hint.Extension] -> HPage (Either Hint.InterpreterError ()) -setLanguageExtensions exs = confirmRunning >> syncRun (Hint.set [Hint.languageExtensions := exs]) - -getSourceDirs :: HPage [FilePath] -getSourceDirs = confirmRunning >>= return . extraSrcDirs - -setSourceDirs :: [FilePath] -> HPage (Either Hint.InterpreterError ()) -setSourceDirs ds = do - let action = do - liftTraceIO $ "setting src dirs: " ++ show ds - Hint.unsafeSetGhcOption "-i" - Hint.unsafeSetGhcOption "-i." - forM_ ds $ Hint.unsafeSetGhcOption . ("-i" ++) - res <- syncRun action - case res of - Right _ -> - modify (\ctx -> ctx{extraSrcDirs = ds, - recoveryLog = recoveryLog ctx >> action >> return ()}) - Left e -> - liftErrorIO $ ("Error setting source dirs", ds, e) - return res - -getGhcOpts :: HPage String -getGhcOpts = confirmRunning >> get >>= return . ghcOptions - -setGhcOpts :: String -> HPage (Either Hint.InterpreterError ()) -setGhcOpts opts = do - let action = do - liftTraceIO $ "setting ghc opts: " ++ opts - Hint.unsafeSetGhcOption opts - res <- syncRun action - case res of - Right _ -> - modify (\ctx -> ctx{ghcOptions = (ghcOptions ctx) ++ " " ++ opts, - recoveryLog = recoveryLog ctx >> action >> return ()}) - Left e -> - liftErrorIO $ ("Error setting ghc opts dirs", opts, e) - return res - -loadPackage :: FilePath -> HPage (Either String PackageIdentifier) -loadPackage file = do - let dir = dropFileName file - res <- liftIO $ tryGetPersistBuildConfig dir - case res of - 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 - libmods = case library pkgdesc of - Nothing -> [] - Just l -> libModules l - exemods = concat (map exeModules $ executables pkgdesc) - mods = uniq . map (joinWith "." . components) $ exemods ++ libmods - 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 - res2 <- syncRun action - case res2 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 - res <- syncRun $ do - liftTraceIO $ "resetting" - Hint.reset - Hint.setImports ["Prelude"] - ms <- Hint.getLoadedModules - liftTraceIO $ "remaining modules: " ++ show ms - case res of - Right _ -> - modify (\ctx -> ctx{loadedModules = empty, - importedModules = fromList ["Prelude"], - extraSrcDirs = [], - ghcOptions = "", - running = Nothing, - recoveryLog = return ()}) - Left e -> - liftErrorIO $ ("Error resetting", e) - return res - -loadModules' :: [String] -> HPage (MVar (Either Hint.InterpreterError ())) -loadModules' ms = do - let action = do - liftTraceIO $ "loading': " ++ show ms - Hint.loadModules ms - Hint.getLoadedModules >>= Hint.setTopLevelModules - res <- asyncRun action - modify (\ctx -> ctx{running = Just $ LoadModules (fromList ms) action}) - return res - -importModules' :: [String] -> HPage (MVar (Either Hint.InterpreterError ())) -importModules' newms = do - ctx <- confirmRunning - let ms = toList $ importedModules ctx - action = do - liftTraceIO $ "importing': " ++ show newms - Hint.setImports $ ms ++ newms - res <- asyncRun action - modify (\c -> c{running = Just $ ImportModules (fromList newms) action}) - return res - -reloadModules' :: HPage (MVar (Either Hint.InterpreterError ())) -reloadModules' = do - ctx <- confirmRunning - let ms = toList $ loadedModules ctx - asyncRun $ do - liftTraceIO $ "reloading': " ++ (show ms) - Hint.loadModules ms - Hint.getLoadedModules >>= Hint.setTopLevelModules - -getLoadedModules' :: HPage (MVar (Either Hint.InterpreterError [ModuleDescription])) -getLoadedModules' = do - confirmRunning_ - asyncRun $ do - mns <- Hint.getLoadedModules - mis <- mapM Hint.isModuleInterpreted mns - return $ zipWith ModDesc mns mis - -getImportedModules' :: HPage (MVar [Hint.ModuleName]) -getImportedModules' = confirmRunning >>= liftIO . newMVar . toList . importedModules - -getModuleExports' :: Hint.ModuleName -> HPage (MVar (Either Hint.InterpreterError [Hint.ModuleElem])) -getModuleExports' mn = confirmRunning >> asyncRun (Hint.getModuleExports mn) - -getLanguageExtensions' :: HPage (MVar (Either Hint.InterpreterError [Hint.Extension])) -getLanguageExtensions' = confirmRunning >> asyncRun (Hint.get Hint.languageExtensions) - -setLanguageExtensions' :: [Hint.Extension] -> HPage (MVar (Either Hint.InterpreterError ())) -setLanguageExtensions' exs = confirmRunning >> asyncRun (Hint.set [Hint.languageExtensions := exs]) - -getSourceDirs' :: HPage (MVar [FilePath]) -getSourceDirs' = confirmRunning >>= liftIO . newMVar . extraSrcDirs - -setSourceDirs' :: [FilePath] -> HPage (MVar (Either Hint.InterpreterError ())) -setSourceDirs' ds = do - let action = do - liftTraceIO $ "setting src dirs: " ++ show ds - Hint.unsafeSetGhcOption "-i" - Hint.unsafeSetGhcOption "-i." - forM_ ds $ Hint.unsafeSetGhcOption . ("-i" ++) - res <- asyncRun action - modify $ \ctx -> ctx{running = Just $ SetSourceDirs ds action} - return res - -getGhcOpts' :: HPage (MVar String) -getGhcOpts' = confirmRunning >> get >>= liftIO . newMVar . ghcOptions - -setGhcOpts' :: String -> HPage (MVar (Either Hint.InterpreterError ())) -setGhcOpts' opts = do - let action = do - liftTraceIO $ "setting ghc opts: " ++ opts - Hint.unsafeSetGhcOption opts - res <- asyncRun action - modify $ \ctx -> ctx{running = Just $ SetGhcOpts opts action} - return res - -reset' :: HPage (MVar (Either Hint.InterpreterError ())) -reset' = do - res <- asyncRun $ do - liftTraceIO $ "resetting'" - Hint.reset - Hint.setImports ["Prelude"] - ms <- Hint.getLoadedModules - liftTraceIO $ "remaining modules: " ++ show ms - modify (\ctx -> ctx{running = Just Reset}) - return res - -cancel :: HPage () -cancel = do - liftTraceIO $ "canceling" - ctx <- get - liftIO $ HS.stop $ server ctx - liftIO $ HPIO.stop $ ioServer ctx - hs <- liftIO $ HS.start - hpios <- liftIO $ HPIO.start - _ <- liftIO $ HS.runIn hs $ recoveryLog ctx - modify (\c -> c{server = hs, - ioServer = hpios, - running = Nothing}) - -prettyPrintError :: Hint.InterpreterError -> String -prettyPrintError (Hint.WontCompile ghcerrs) = "Can't compile: " ++ (joinWith "\n" $ map Hint.errMsg ghcerrs) -prettyPrintError (Hint.UnknownError errStr) = "Error: " ++ errStr -prettyPrintError (Hint.NotAllowed errStr) = "Not Allowed Action: " ++ errStr -prettyPrintError (Hint.GhcException errStr) = errStr - --- PRIVATE FUNCTIONS ----------------------------------------------------------- -modifyPage :: (Page -> Page) -> HPage () -modifyPage f = get >>= (flip modifyPageNth) f . currentPage - -modifyPageNth :: Int -> (Page -> Page) -> HPage () -modifyPageNth i f = withPageIndex i $ modify (\c -> - let pgs = pages c - newPage = f $ pgs !! i - in c{pages = insertAt i [newPage] pgs}) - -getPage :: HPage Page -getPage = get >>= getPageNth . currentPage - -getPageNth :: Int -> HPage Page -getPageNth i = withPageIndex i $ get >>= return . (!! i) . pages - -withPageIndex :: Int -> HPage a -> HPage a -withPageIndex i acc = get >>= withIndex i acc . pages - -withExprIndex :: Int -> HPage a -> HPage a -withExprIndex i acc = getPage >>= withIndex i acc . expressions - -withIndex :: Show b => Int -> HPage a -> [b] -> HPage a -withIndex i acc is = case i of - -1 -> - fail "Nothing selected" - x | x >= length is -> - fail "Invalid index" - _ -> - acc - -runInExprNth :: (String -> Hint.InterpreterT IO String) -> Int -> HPage (Either Hint.InterpreterError String) -runInExprNth action i = do - page <- getPage - let exprs = expressions page - flip (withIndex i) exprs $ do - let expr = exprText $ exprs !! i - syncRun $ if "" == expr - then return "" - else action expr - -getIOFromExprNth :: Int -> HPage (Either Hint.InterpreterError (IO String)) -getIOFromExprNth i = - do - page <- getPage - let exprs = expressions page - flip (withIndex i) exprs $ let (b, item : a) = splitAt i exprs - lets = filter isNamedExpr $ b ++ a - expr = "(" ++ letsToString lets ++ exprText item ++ ") >>= return . show" - in syncRun $ Hint.interpret expr (Hint.as :: IO String) - -getListFromExprNth :: Int -> HPage (Either Hint.InterpreterError [String]) -getListFromExprNth i = - do - page <- getPage - let exprs = expressions page - flip (withIndex i) exprs $ let (b, item : a) = splitAt i exprs - lets = filter isNamedExpr $ b ++ a - expr = "map show (" ++ letsToString lets ++ exprText item ++ ")" - in syncRun $ Hint.interpret expr (Hint.as :: [String]) - -runInExprNthWithLets :: (String -> Hint.InterpreterT IO String) -> Int -> HPage (Either Hint.InterpreterError String) -runInExprNthWithLets action i = do - page <- getPage - let exprs = expressions page - flip (withIndex i) exprs $ let (b, item : a) = splitAt i exprs - lets = filter isNamedExpr $ b ++ a - expr = letsToString lets ++ exprText item - in do - liftDebugIO ("runInExprNthWithLets", expr) - syncRun $ if "" == exprText item - then return "" - else action expr - -syncRun :: Hint.InterpreterT IO a -> HPage (Either Hint.InterpreterError a) -syncRun action = do - liftTraceIO "sync - confirming" - ctx <- confirmRunning - liftTraceIO "sync - running" - liftIO $ HS.runIn (server ctx) action - -asyncRun :: Hint.InterpreterT IO a -> HPage (MVar (Either Hint.InterpreterError a)) -asyncRun action = do - liftTraceIO "async - running" - ctx <- confirmRunning - liftIO $ HS.asyncRunIn (server ctx) action - -confirmRunning_ :: HPage () -confirmRunning_ = confirmRunning >> return () - -confirmRunning :: HPage Context -confirmRunning = modify (\ctx -> apply (running ctx) ctx) >> get - -apply :: Maybe InFlightData -> Context -> Context -apply Nothing c = c -apply (Just Reset) c = c{loadedModules = empty, - importedModules = fromList ["Prelude"], - extraSrcDirs = [], - ghcOptions = "", - recoveryLog = return (), - running = Nothing} -apply (Just LoadModules{loadingModules = lms, runningAction = ra}) c = - c{loadedModules = union lms (loadedModules c), - recoveryLog = (recoveryLog c) >> ra} -apply (Just ImportModules{importingModules = ims, runningAction = ra}) c = - c{importedModules = union ims (importedModules c), - recoveryLog = (recoveryLog c) >> ra} -apply (Just SetSourceDirs{settingSrcDirs = ssds, runningAction = ra}) c = - c{extraSrcDirs = ssds, recoveryLog = (recoveryLog c) >> ra} -apply (Just SetGhcOpts{settingGhcOpts = opts, runningAction = ra}) c = - c{ghcOptions = (ghcOptions c) ++ " " ++ opts, recoveryLog = (recoveryLog c) >> ra} - -exprFromString :: String -> [Expression] -exprFromString s = map Exp $ splitOn "\n\n" s - -isNamedExpr :: Expression -> Bool -isNamedExpr e = case Xs.parseDecl (exprText e) of - Xs.ParseOk _ -> True - _ -> False - -isType :: (Xs.Type -> Bool) -> String -> Bool -isType f t = case Xs.parseType t of - Xs.ParseOk ty -> f ty - _ -> False -- couldn't parse - -isList :: String -> Bool -isList = isType isList' - -isChar, isList' :: Xs.Type -> Bool -isList' (Xs.TyForall _ _ inttype) = isList' inttype -isList' (Xs.TyParen inttype) = isList' inttype -isList' (Xs.TyList inttype) = not $ isChar inttype -isList' (Xs.TyCon (Xs.Special Xs.ListCon)) = True -isList' _ = False - -isChar (Xs.TyForall _ _ inttype) = isChar inttype -isChar (Xs.TyParen inttype) = isChar inttype -isChar (Xs.TyCon (Xs.Qual _ (Xs.Ident "Char"))) = True -isChar (Xs.TyCon (Xs.UnQual (Xs.Ident "Char"))) = True -isChar _ = False - -isIO :: String -> Bool -isIO = isType isIO' - -isIO'', isIO' :: Xs.Type -> Bool -isIO' (Xs.TyForall _ _ inttype) = isIO' inttype -isIO' (Xs.TyParen inttype) = isIO' inttype -isIO' (Xs.TyApp inttype _) = isIO'' inttype -isIO' _ = False - -isIO'' (Xs.TyForall _ _ inttype) = isIO'' inttype -isIO'' (Xs.TyParen inttype) = isIO'' inttype -isIO'' (Xs.TyCon (Xs.Qual _ (Xs.Ident "IO"))) = True -isIO'' (Xs.TyCon (Xs.UnQual (Xs.Ident "IO"))) = True -isIO'' _ = False - -exprFromString' :: String -> Int -> ([Expression], Int) -exprFromString' "" 0 = ([], -1) -exprFromString' s 0 = (exprFromString s, 0) -exprFromString' s i = (exprFromString s, - flip (-) 1 . length . splitOn "\n\n" $ take i s) - -toString :: Page -> String -toString = joinWith "\n\n" . map exprText . expressions - -splitOn :: Eq a => [a] -> [a] -> [[a]] -splitOn [] xs = [xs] -splitOn _ [] = [] -splitOn s xs = splitOn' [] s xs - -splitOn' :: Eq a => [a] -> [a] -> [a] -> [[a]] -splitOn' [] _ [] = [] -splitOn' acc _ [] = [reverse acc] -splitOn' acc s r@(x:xs) - | isPrefixOf s r = (reverse acc) : splitOn' [] s (drop (length s) r) - | otherwise = splitOn' (x:acc) s xs - -joinWith :: [a] -> [[a]] -> [a] -joinWith _ [] = [] -joinWith sep (x:xs) = x ++ (concat . map (sep ++) $ xs) - -insertAt :: Int -> [a] -> [a] -> [a] -insertAt 0 new [] = new -insertAt i new old | i == length old = old ++ new - | otherwise = let (before, (_:after)) = splitAt i old - in before ++ new ++ after - -showWithCurrent :: Show a => [a] -> Int -> String -> (String -> String) -> String -showWithCurrent allItems curItem sep mark = - drop (length sep) . concat $ map (showNth allItems curItem) [0..itemCount - 1] - where itemCount = length allItems - showNth list sel cur = sep ++ ((if sel == cur then mark else id) $ show $ list !! cur) - -modifyWithUndo :: (Page -> Page) -> HPage () -modifyWithUndo f = modifyPage (\page -> - let newPage = f page - undoAct = modifyPage (\pp -> pp{expressions = expressions page, - currentExpr = currentExpr page}) - in newPage{undoActions = undoAct : undoActions page, - redoActions = []}) - -emptyPage :: Page -emptyPage = Page [] (-1) [] [] [] Nothing - -letsToString :: [Expression] -> String -letsToString [] = "" -letsToString exs = "let\n " ++ joinWith ";\n " (map (joinWith "\n " . lines . exprText) exs) ++ "\n in " - -moduleElemDesc :: Hint.ModuleElem -> Hint.InterpreterT IO ModuleElemDesc -moduleElemDesc (Hint.Fun fn) = do - t <- (Hint.typeOf fn) `catchError` (\_ -> return []) - return MEFun{funName = fn, funType = t} -moduleElemDesc (Hint.Class cn cfs) = do - mcfs <- flip mapM cfs $ moduleElemDesc . Hint.Fun - return MEClass{clsName = cn, clsFuns = mcfs} -moduleElemDesc (Hint.Data dn dcs) = do - mdcs <- flip mapM dcs $ moduleElemDesc . Hint.Fun - return MEData{datName = dn, datCtors = mdcs} - -{- | Given a list, returns a new list with all duplicate elements removed. -For example: - ->uniq "Mississippi" -> "Misp" - -You should not rely on this function necessarily preserving order, though -the current implementation happens to. - -This function is not compatible with infinite lists. - -TAKEN FROM: http://hackage.haskell.org/packages/archive/MissingH/1.0.0/doc/html/src/Data-List-Utils.html#uniq -} -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 - [_header, 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." 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 @@ -433,13 +433,17 @@ if HP.isIntExprs interp then do liftDebugIO "Values received in valueFiller" - set txtValue [text := "["] + set txtValue [text := ""] listValueFiller guiCtx $ HP.intValues interp return "" -- It can't be a string error as -- we're generating the string - else do - liftDebugIO "Value received in valueFiller" - singleValueFiller guiCtx $ HP.intValue interp + else if HP.isIntExpr interp + then do + liftDebugIO "Value received in valueFiller" + singleValueFiller guiCtx $ HP.intValue interp + else do + liftDebugIO "IO Value received in valueFiller" + ioValueFiller guiCtx $ HP.intResult interp errs <- varGet varErrors case (statusText, errs) of ("", []) -> -- No errors @@ -461,21 +465,23 @@ -- or appends the errors generated by its computation to varErrors, returning -- the error description if there was an error. listValueFiller :: GUIContext -> [String] -> IO () -listValueFiller GUICtx{guiResults = GUIRes{resValue = txtValue}} [] = - textCtrlAppendText txtValue "]" >> return () listValueFiller guiCtx@GUICtx{guiResults = - GUIRes{resErrors = varErrors, - resValue = txtValue}} (v:vs) = + GUIRes{resValue = txtValue}} vs = do + debugIO "List Value Filler starting..." + textCtrlAppendText txtValue "[" + listValueFiller' "" guiCtx vs + textCtrlAppendText txtValue "]" + +listValueFiller' :: String -> GUIContext -> [String] -> IO () +listValueFiller' _ _ [] = return () +listValueFiller' comma guiCtx@GUICtx{guiResults = + GUIRes{resValue = txtValue}} (val:vs) = + do debugIO "List Value Filler running for a value..." - status <- singleValueFiller guiCtx v - debugIO $ "...value processed: " ++ status - _errs <- case status of - "" -> return [] - err -> textCtrlAppendText txtValue bottomString >> - varUpdate varErrors (++ [GUIBtm err v]) - textCtrlAppendText txtValue $ if vs /= [] then ", " else "" - listValueFiller guiCtx vs + textCtrlAppendText txtValue comma + valueFill guiCtx val >>= textCtrlAppendText txtValue + listValueFiller' ", " guiCtx vs -- | Processes the string, computes its value and appends it to the txtValue -- or appends the errors generated by its computation to varErrors, returning @@ -515,6 +521,17 @@ valueFill guiCtx t >>= textCtrlAppendText txtValue recursiveValueFiller guiCtx $ tail val +-- | Same as singleValueFiller but first we wait for the result... +ioValueFiller :: GUIContext -> MVar (Either SomeException String) -> IO String +ioValueFiller guiCtx var = + do + res <- takeMVar var + case res of + Left err -> + return $ show err + Right val -> + singleValueFiller guiCtx val + valueFill :: GUIContext -> String -> IO String valueFill guiCtx@GUICtx{guiResults = GUIRes{resErrors = varErrors}, guiCharTimer = charTimer, @@ -1049,6 +1066,12 @@ poc <- liftIO $ get btnInterpret $ on command let revert = do debugIO "Cancelling..." + cancelRes <- tryIn' model HP.cancel + case cancelRes of + Left err -> + errorDialog win "Error" $ "There was an unexpected error when cancelling. It's recommended to restart the application:\n" ++ err + Right () -> + return () newvf <- spawn $ valueFiller guiCtx debugIO "Killing the value filler..." swapMVar vfv newvf >>= kill diff --git a/src/HPage/IOServer.hs b/src/HPage/IOServer.hs deleted file mode 100644 --- a/src/HPage/IOServer.hs +++ /dev/null @@ -1,24 +0,0 @@ - -module HPage.IOServer ( - start, stop, runIn, ServerHandle - ) where - -import Control.Exception (try, SomeException) -import Control.Monad -import Control.Monad.Trans -import Control.Concurrent.Process - -newtype ServerHandle = SH {handle :: Handle (IO ())} - -start :: IO ServerHandle -start = spawn ioRunner >>= return . SH - where ioRunner = forever $ recv >>= liftIO - -runIn :: ServerHandle -> IO a -> IO (Either SomeException a) -runIn server action = runHere $ do - me <- self - sendTo (handle server) $ try action >>= sendTo me - recv - -stop :: ServerHandle -> IO () -stop = kill . handle diff --git a/src/HPage/Server.hs b/src/HPage/Server.hs deleted file mode 100644 --- a/src/HPage/Server.hs +++ /dev/null @@ -1,27 +0,0 @@ - -module HPage.Server ( - start, stop, runIn, ServerHandle - ) where - -import Control.Monad -import Control.Monad.Trans -import Control.Concurrent.Process -import HPage.Control -import HPage.Utils.Log - -newtype ServerHandle = SH {handle :: Handle (HPage ())} - -start :: IO ServerHandle -start = (spawn $ makeProcess evalHPage pageRunner) >>= return . SH - where pageRunner = forever $ recv >>= lift - -runIn :: ServerHandle -> HPage a -> IO a -runIn server action = runHere $ do - liftDebugIO "Sending an action..." - me <- self - sendTo (handle server) $ action >>= sendTo me - liftDebugIO "...waiting for result" - recv - -stop :: ServerHandle -> IO () -stop = kill . handle 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 @@ -12,7 +12,7 @@ logIO lvl msg = getCurrentTime >>= \ts -> putStrLn $ (show ts) ++ " (" ++ (show lvl) ++ "): " ++ (show msg) liftLogIO :: (MonadIO m, Show a) => LogLevel -> a -> m () -liftLogIO lvl = liftIO . (logIO lvl) +liftLogIO _ _ = return () -- lvl = liftIO . (logIO lvl) traceIO, debugIO, infoIO, warnIO, errorIO, fatalIO :: Show a => a -> IO () liftTraceIO, liftDebugIO, liftInfoIO, liftWarnIO, liftErrorIO, liftFatalIO :: (MonadIO m, Show a) => a -> m ()