hpage 0.11.1 → 0.12.0
raw patch · 7 files changed
+63/−1107 lines, 7 filesdep −MonadCatchIO-mtldep −cabal-macosxdep ~bytestringdep ~directorydep ~hintsetup-changed
Dependencies removed: MonadCatchIO-mtl, cabal-macosx
Dependency ranges changed: bytestring, directory, hint, hint-server, mtl, time
Files
- Setup.hs +10/−1
- hpage.cabal +13/−14
- src/HPage/Control.hs +0/−1024
- src/HPage/GUI/FreeTextWindow.hs +39/−16
- src/HPage/IOServer.hs +0/−24
- src/HPage/Server.hs +0/−27
- src/HPage/Utils/Log.hs +1/−1
Setup.hs view
@@ -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 ()
hpage.cabal view
@@ -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
− src/HPage/Control.hs
@@ -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."
src/HPage/GUI/FreeTextWindow.hs view
@@ -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
− src/HPage/IOServer.hs
@@ -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
− src/HPage/Server.hs
@@ -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
src/HPage/Utils/Log.hs view
@@ -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 ()