hpage (empty) → 0.1.1
raw patch · 27 files changed
+2502/−0 lines, 27 filesdep +Cabaldep +MonadCatchIO-mtldep +Win32build-type:Customsetup-changedbinary-added
Dependencies added: Cabal, MonadCatchIO-mtl, Win32, array, base, bytestring, containers, cpphs, directory, filepath, ghc, ghc-mtl, ghc-paths, haskell-src, haskell-src-exts, haskell98, hint, hpc, monad-loops, mtl, old-locale, old-time, packedstring, pretty, process, random, stm, syb, template-haskell, unix, utf8-string, wx, wxcore
Files
- LICENSE +31/−0
- README +3/−0
- Setup.hs +91/−0
- hpage.cabal +76/−0
- res/images/about.png binary
- res/images/copy.png binary
- res/images/cut.png binary
- res/images/icon/hPage.icns binary
- res/images/icon/hpage.gif binary
- res/images/icon/hpage.jpg binary
- res/images/icon/hpage.png binary
- res/images/icon/hpage.tif binary
- res/images/new.png binary
- res/images/open.png binary
- res/images/paste.png binary
- res/images/reload.png binary
- res/images/run.png binary
- res/images/save.png binary
- src/Control/Concurrent/Process.hs +74/−0
- src/HPage/Control.hs +609/−0
- src/HPage/GUI/FreeTextWindow.hs +567/−0
- src/HPage/Server.hs +39/−0
- src/HPage/Test/Server.hs +900/−0
- src/Language/Haskell/Interpreter/Server.hs +53/−0
- src/Language/Haskell/Interpreter/Utils.hs +14/−0
- src/Main.hs +8/−0
- src/Utils/Log.hs +37/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Fernando Brujo Benavides 2009++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Fernando Brujo Benavides nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ README view
@@ -0,0 +1,3 @@+we've reach our first alpha release!!++This file will contain information about how to install the system in the different platforms, but for now it's here just to show happiness :)
+ Setup.hs view
@@ -0,0 +1,91 @@+{-# 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.Simple+import Distribution.Simple.LocalBuildInfo++#ifndef WIN32+import System.Posix.Files (fileMode, getFileStatus, setFileMode,+ ownerExecuteMode, groupExecuteMode, otherExecuteMode)+import Data.Bits ( (.|.) )+#endif++main :: IO ()+main = do+ putStrLn $ "processing for " ++ os+ defaultMainWithHooks $ addMacHook simpleUserHooks+ where+ addMacHook h =+ case os of+ "darwin" -> h { postInst = appBundleHook,+ runTests = hPageTestRunner } -- is it OK to treat darwin as synonymous with MacOS X?+ _ -> 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+ 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 ()+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 ()+#ifdef WIN32+makeExecutable = const (return ())+#else+makeExecutable f =+ do st <- getFileStatus f+ let m = fileMode st+ m2 = m .|. ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode+ setFileMode f m2+#endif++hPageTestRunner :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()+hPageTestRunner _ _ _ _ = do+ system "runhaskell -i./src src/HPage/Test/Server.hs"+ return ()
+ hpage.cabal view
@@ -0,0 +1,76 @@+name: hpage+version: 0.1.1+cabal-version: >=1.6+build-type: Custom+license: BSD3+license-file: LICENSE+copyright: 2009 Fernando "Brujo" Benavides+maintainer: greenmellon@gmail.com+stability: provisional+homepage: http://elbrujohalcon.github.com/hPage/+package-url: http://code.haskell.org/hpage+bug-reports: http://github.com/elbrujohalcon/hPage/issues+synopsis: A scrapbook for Haskell developers+description: hPage is targeted at those haskell developers which also like to work with dynamic GUIs and wish to have something like Smalltalk's Workbook or jPage for Java. Using hPage developers can write haskell expressions, evaluate and test them, load, unload and (of course) reload modules and then, re-evaluate the same expressions (ghci anyone?). Developed over wxWidgets, hPage is multi-platform by nature and works in every scenario where ghc and wxWidgets work.+category: Development, IDE, Editor+author: Fernando "Brujo" Benavides+tested-with: GHC ==6.10.3, GHC ==6.10.4+data-files: LICENSE README+ res/images/*.png+ res/images/icon/hpage.gif+ res/images/icon/hPage.icns+ res/images/icon/hpage.jpg+ res/images/icon/hpage.png+ res/images/icon/hpage.tif+data-dir: ""+extra-source-files: Setup.hs+extra-tmp-files:++source-repository head+ type: git+ location: git://github.com/elbrujohalcon/hPage.git++Executable hpage+ if os(windows)+ build-depends: Win32 >=2.2.0.0+ extra-libraries: kernel32+ else+ build-depends: unix >=2.3.1.0+ build-depends: Cabal >=1.6.0.1, mtl >=1.1.0.2, MonadCatchIO-mtl >= 0.1.0.1, syb,+ array >=0.2.0.0, containers >=0.2.0.1, filepath >=1.1.0.2,+ old-locale >=1.0.0.1, old-time >=1.0.0.2, directory >=1.0.0.3,+ pretty >=1.0.1.0, process >=1.0.1.1, bytestring >=0.9.1.4, random >=1.0.0.1,+ haskell98, hpc >=0.5.0.3, packedstring >=0.1.0.1, template-haskell, ghc >=6.10.3,+ base ==3.0.3.1, haskell-src >=1.0.1.3, stm >=2.1.1.2, wxcore >=0.11.1.2, wx >=0.11.1.2,+ ghc-mtl >=1.0.0.0, ghc-paths >=0.1.0.5, utf8-string >=0.3.4, hint >=0.3.1.0,+ monad-loops >=0.3.0.2, cpphs >=1.8, haskell-src-exts >=1.1.3.1+ main-is: Main.hs+ buildable: True+ build-tools:+ cpp-options:+ cc-options:+ ld-options:+ pkgconfig-depends:+ frameworks:+ c-sources:+ extensions: CPP+ if os(windows)+-- extra-lib-dirs: C:/cygwin/lib/w32api+ includes: windows.h+-- include-dirs: C:/cygwin/usr/include/w32api+ install-includes:+ hs-source-dirs: src+ other-modules: Control.Concurrent.Process,+ HPage.Control,+ HPage.GUI.FreeTextWindow,+ HPage.Server,+ HPage.Test.Server,+ Language.Haskell.Interpreter.Server,+ Language.Haskell.Interpreter.Utils,+ Utils.Log+ ghc-prof-options: -auto-all -prof+ ghc-shared-options: -auto-all -prof+ ghc-options: -package wx -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns+ hugs-options:+ nhc98-options:+ jhc-options:
+ res/images/about.png view
binary file changed (absent → 22414 bytes)
+ res/images/copy.png view
binary file changed (absent → 16256 bytes)
+ res/images/cut.png view
binary file changed (absent → 13257 bytes)
+ res/images/icon/hPage.icns view
binary file changed (absent → 207478 bytes)
+ res/images/icon/hpage.gif view
binary file changed (absent → 28283 bytes)
+ res/images/icon/hpage.jpg view
binary file changed (absent → 67410 bytes)
+ res/images/icon/hpage.png view
binary file changed (absent → 455333 bytes)
+ res/images/icon/hpage.tif view
binary file changed (absent → 1052782 bytes)
+ res/images/new.png view
binary file changed (absent → 14064 bytes)
+ res/images/open.png view
binary file changed (absent → 20832 bytes)
+ res/images/paste.png view
binary file changed (absent → 15977 bytes)
+ res/images/reload.png view
binary file changed (absent → 16957 bytes)
+ res/images/run.png view
binary file changed (absent → 13576 bytes)
+ res/images/save.png view
binary file changed (absent → 14560 bytes)
+ src/Control/Concurrent/Process.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE GeneralizedNewtypeDeriving,+ MultiParamTypeClasses,+ FlexibleInstances,+ FunctionalDependencies,+ UndecidableInstances #-} ++module Control.Concurrent.Process (+ Handle, sendTo,+ ReceiverT, recv, self,+ sendRecv,+ Process, makeProcess, runHere, spawn+ ) where++import Control.Monad.Reader+import Control.Monad.State.Class+import Control.Monad.Writer.Class+import Control.Monad.Error.Class+import Control.Monad.CatchIO+import Data.Monoid+import Control.Concurrent+import Control.Concurrent.Chan++newtype Handle r = PH {chan :: Chan r}++newtype ReceiverT r m a = RT { internalReader :: ReaderT (Handle r) m a }+ deriving (Monad, MonadIO, MonadTrans, MonadCatchIO)++type Process r = ReceiverT r IO++sendTo :: MonadIO m => Handle a -> a -> m ()+sendTo ph = liftIO . writeChan (chan ph)++recv :: MonadIO m => ReceiverT r m r+recv = RT $ ask >>= liftIO . readChan . chan++sendRecv :: MonadIO m => Handle a -> a -> ReceiverT r m r+sendRecv h a = sendTo h a >> recv ++spawn :: MonadIO m => Process r k -> m (Handle r) +spawn p = liftIO $ do+ pChan <- newChan+ let handle = PH { chan = pChan }+ let action = runReaderT (internalReader p) handle+ forkIO $ action >> return ()+ return handle++runHere :: MonadIO m => Process r t -> m t+runHere p = liftIO (runReaderT (internalReader p) . PH =<< newChan)++self :: Monad m => ReceiverT r m (Handle r)+self = RT ask++makeProcess :: (m t -> IO s) -> ReceiverT r m t -> Process r s +makeProcess f (RT a) = RT (mapReaderT f a)++instance MonadState s m => MonadState s (ReceiverT r m) where+ get = lift get+ put = lift . put++instance MonadReader r m => MonadReader r (ReceiverT r m) where+ ask = lift ask+ local = onInner . local ++instance (Monoid w, MonadWriter w m) => MonadWriter w (ReceiverT w m) where+ tell = lift . tell+ listen = onInner listen+ pass = onInner pass++instance MonadError e m => MonadError e (ReceiverT r m) where+ throwError = lift . throwError+ catchError (RT a) h = RT $ a `catchError` (\e -> internalReader $ h e)++onInner :: (m a -> m b) -> ReceiverT r m a -> ReceiverT r m b+onInner f (RT m) = RT $ mapReaderT f m
+ src/HPage/Control.hs view
@@ -0,0 +1,609 @@+{-# LANGUAGE GeneralizedNewtypeDeriving,+ MultiParamTypeClasses,+ FlexibleInstances,+ FunctionalDependencies,+ 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 --+ valueOf, valueOfNth, kindOf, kindOfNth, typeOf, typeOfNth,+ loadModules, reloadModules, getLoadedModules,+ valueOf', valueOfNth', kindOf', kindOfNth', typeOf', typeOfNth',+ loadModules', reloadModules', getLoadedModules',+ reset, reset',+ cancel,+ Hint.InterpreterError, Hint.prettyPrintError,+ -- DEBUG --+ ctxString+ ) where++import System.IO+import System.Directory+import Data.Set (Set, empty, union, fromList, toList)+import Data.Char+import Control.Monad.Loops+import Control.Monad.Error+import Control.Monad.State+import Control.Monad.State.Class+import Control.Concurrent.MVar+import qualified Language.Haskell.Interpreter as Hint+import qualified Language.Haskell.Interpreter.Utils as Hint+import qualified Language.Haskell.Interpreter.Server as HS+import Utils.Log+import Data.List (isPrefixOf)+import qualified Data.List as List+import qualified Data.ByteString.Char8 as Str+import Language.Haskell.Exts.Parser++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 ()+ } | 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 { -- Pages --+ pages :: [Page],+ currentPage :: Int,+ -- Hint --+ loadedModules :: Set String,+ server :: HS.ServerHandle,+ running :: Maybe InFlightData,+ recoveryLog :: Hint.InterpreterT IO () -- To allow cancelation of actions+ }+ +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 HPage = HPageT IO++evalHPage :: HPage a -> IO a+evalHPage hpt = do+ hs <- liftIO $ HS.start+ let nop = return ()+ let emptyContext = Context [emptyPage] 0 empty hs Nothing nop+ (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) = fromString' 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) = fromString' 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 (fromString 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) (fromString 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})+ +valueOf, kindOf, typeOf :: HPage (Either Hint.InterpreterError String)+valueOf = getPage >>= valueOfNth . currentExpr+kindOf = getPage >>= kindOfNth . currentExpr+typeOf = getPage >>= typeOfNth . currentExpr++valueOfNth, kindOfNth, typeOfNth :: Int -> HPage (Either Hint.InterpreterError String)+valueOfNth = runInExprNthWithLets Hint.eval+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++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 [Hint.ModuleName])+getLoadedModules = confirmRunning >> syncRun Hint.getLoadedModules++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,+ running = Nothing,+ recoveryLog = return ()})+ Left e ->+ liftErrorIO $ ("Error resetting", e)+ return res++valueOf', kindOf', typeOf' :: HPage (MVar (Either Hint.InterpreterError String))+valueOf' = getPage >>= valueOfNth' . currentExpr+kindOf' = getPage >>= kindOfNth' . currentExpr+typeOf' = getPage >>= typeOfNth' . currentExpr++valueOfNth', kindOfNth', typeOfNth' :: Int -> HPage (MVar (Either Hint.InterpreterError String))+valueOfNth' = runInExprNthWithLets' Hint.eval+kindOfNth' = runInExprNth' Hint.kindOf+typeOfNth' = runInExprNthWithLets' Hint.typeOf++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+ ++reloadModules' :: HPage (MVar (Either Hint.InterpreterError ()))+reloadModules' = do+ page <- confirmRunning+ let ms = toList $ loadedModules page+ asyncRun $ do+ liftTraceIO $ "reloading': " ++ (show ms)+ Hint.loadModules ms+ Hint.getLoadedModules >>= Hint.setTopLevelModules++getLoadedModules' :: HPage (MVar (Either Hint.InterpreterError [Hint.ModuleName]))+getLoadedModules' = confirmRunning >> asyncRun Hint.getLoadedModules++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+ hs <- liftIO $ HS.start+ liftIO $ HS.runIn hs $ recoveryLog ctx+ modify (\c -> c{server = hs,+ running = Nothing})+ ++-- 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++runInExprNth' :: (String -> Hint.InterpreterT IO String) -> Int -> HPage (MVar (Either Hint.InterpreterError String))+runInExprNth' action i = do+ page <- getPage+ let exprs = expressions page+ flip (withIndex i) exprs $ do+ let expr = exprText $ exprs !! i+ asyncRun $ if "" == expr+ then return ""+ else action expr++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 syncRun $ if "" == exprText item+ then return ""+ else action expr++runInExprNthWithLets' :: (String -> Hint.InterpreterT IO String) -> Int -> HPage (MVar (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 asyncRun $ action expr++syncRun :: Hint.InterpreterT IO a -> HPage (Either Hint.InterpreterError a)+syncRun action = do+ liftTraceIO "sync - running"+ page <- confirmRunning+ liftIO $ HS.runIn (server page) action++asyncRun :: Hint.InterpreterT IO a -> HPage (MVar (Either Hint.InterpreterError a)) +asyncRun action = do+ liftTraceIO "async - running"+ page <- confirmRunning+ liftIO $ HS.asyncRunIn (server page) action++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,+ recoveryLog = return (),+ running = Nothing}+apply (Just lm) c = c{loadedModules = union (loadingModules lm) (loadedModules c),+ recoveryLog = (recoveryLog c) >> (runningAction lm)}++fromString :: String -> [Expression]+fromString s = map Exp $ splitOn "\n\n" s++isNamedExpr :: Expression -> Bool+isNamedExpr e = case parseDecl (exprText e) of+ ParseOk _ -> True+ _ -> False ++fromString' :: String -> Int -> ([Expression], Int)+fromString' "" 0 = ([], -1)+fromString' s 0 = (fromString s, 0)+fromString' s i = (fromString 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 " ++ joinWith "; " (map exprText exs) ++ " in "
+ src/HPage/GUI/FreeTextWindow.hs view
@@ -0,0 +1,567 @@+{-# LANGUAGE GeneralizedNewtypeDeriving,+ MultiParamTypeClasses,+ FlexibleInstances,+ FlexibleContexts,+ FunctionalDependencies,+ UndecidableInstances #-}+ +module HPage.GUI.FreeTextWindow ( gui ) where++import Control.Concurrent.Process+import Control.Concurrent.MVar+import System.FilePath+import System.IO.Error hiding (try)+import Data.List+import Data.Bits+import Data.Char (toLower)+import Control.Monad.Error+import Control.Monad.Loops+import Graphics.UI.WX+import Graphics.UI.WXCore+import Graphics.UI.WXCore.Types+import Graphics.UI.WXCore.Dialogs+import Graphics.UI.WXCore.Events+import Graphics.UI.WXCore.WxcClasses+import qualified HPage.Control as HP+import qualified HPage.Server as HPS+import Utils.Log++import Paths_hpage -- cabal locations of data files++imageFile :: FilePath -> IO FilePath+imageFile = getDataFileName . ("res/images/"++)++data GUIResultRow = GUIRRow { grrButton :: Button (),+ grrText :: TextCtrl ()}++data GUIResults = GUIRes { resValue :: GUIResultRow,+ resType :: GUIResultRow,+ resKind :: GUIResultRow }++data GUIContext = GUICtx { guiWin :: Frame (),+ guiPages :: SingleListBox (),+ guiModules :: SingleListBox (),+ guiCode :: TextCtrl (),+ guiResults :: GUIResults,+ guiStatus :: StatusField,+ guiTimer :: Var (TimerEx ()),+ guiSearch :: FindReplaceData ()} ++gui :: IO ()+gui =+ do+ -- Server context+ model <- HPS.start+ + win <- frame [text := "hPage"]+ imageFile "icon/hpage.tif" >>= topLevelWindowSetIconFromFile win + + set win [on closing := HPS.stop model >> propagateEvent]++ -- Containers+ pnl <- panel win []+ splLR <- splitterWindow pnl []+ pnlL <- panel splLR []+ pnlR <- panel splLR []+ + -- Text page...+ -- txtCode <- styledTextCtrl win []+ txtCode <- textCtrl pnlR [font := fontFixed]+ + -- Document Selector+ lstModules <- singleListBox pnlL [style := wxLB_NEEDED_SB]+ lstPages <- singleListBox pnlL [style := wxLB_NEEDED_SB]++ -- Results list+ txtValue <- textEntry pnlR [style := wxTE_READONLY]+ txtType <- textEntry pnlR [style := wxTE_READONLY]+ txtKind <- textEntry pnlR [style := wxTE_READONLY]+ + -- Status bar...+ status <- statusField [text := "hello... this is hPage! type in your instructions :)"]+ refreshTimer <- timer win [interval := 1000000, on command := debugIO "Inactivity detected"]+ varTimer <- varCreate refreshTimer+ set win [statusBar := [status]]+ + btnGetValue <- button pnlR [text := "Value"]+ btnGetType <- button pnlR [text := "Type"]+ btnGetKind <- button pnlR [text := "Kind"]+ + search <- findReplaceDataCreate wxFR_DOWN+ + let grrValue = GUIRRow btnGetValue txtValue+ let grrType = GUIRRow btnGetType txtType+ let grrKind = GUIRRow btnGetKind txtKind+ let guiRes = GUIRes grrValue grrType grrKind+ let guiCtx = GUICtx win lstPages lstModules txtCode guiRes status varTimer search + let onCmd name acc = traceIO ("onCmd", name) >> acc model guiCtx++ set btnGetValue [on command := onCmd "getValue" getValue]+ set btnGetType [on command := onCmd "getType" getType]+ set btnGetKind [on command := onCmd "getKind" getKind]+ + -- Events+ set lstPages [on select := onCmd "pageChange" pageChange]+ set txtCode [on keyboard := \_ -> onCmd "restartTimer" restartTimer >> propagateEvent,+ on mouse := \e -> case e of+ MouseLeftUp _ _ -> onCmd "mouseEvent" restartTimer >> propagateEvent+ MouseLeftDClick _ _ -> onCmd "mouseEvent" restartTimer >> propagateEvent+ _ -> propagateEvent]+ + -- Menu bar...+ -- menuBar win []+ mnuPage <- menuPane [text := "Page"]+ mitNew <- menuItem mnuPage [text := "&New\tCtrl-n", on command := onCmd "runHP' addPage" $ runHP' HP.addPage]+ menuItem mnuPage [text := "&Close\tCtrl-w", on command := onCmd "runHP' closePage" $ runHP' HP.closePage]+ menuItem mnuPage [text := "&Close All\tCtrl-Shift-w", on command := onCmd "runHP' closeAllPages" $ runHP' HP.closeAllPages]+ menuLine mnuPage+ mitOpen <- menuItem mnuPage [text := "&Open...\tCtrl-o", on command := onCmd "openPage" openPage]+ mitSave <- menuItem mnuPage [text := "&Save\tCtrl-s", on command := onCmd "savePage" savePage]+ menuItem mnuPage [text := "&Save as...\tCtrl-Shift-s", on command := onCmd "savePageAs" savePageAs]+ menuLine mnuPage+ menuQuit mnuPage []+ + mnuEdit <- menuPane [text := "Edit"]+ menuItem mnuEdit [text := "&Undo\tCtrl-z", on command := onCmd "runHP' undo" $ runHP' HP.undo]+ menuItem mnuEdit [text := "&Redo\tCtrl-Shift-z", on command := onCmd "runHP' redo" $ runHP' HP.redo]+ menuLine mnuEdit+ mitCut <- menuItem mnuEdit [text := "C&ut\tCtrl-x", on command := onCmd "cut" cut]+ mitCopy <- menuItem mnuEdit [text := "&Copy\tCtrl-c", on command := onCmd "copy" copy]+ mitPaste <- menuItem mnuEdit [text := "&Paste\tCtrl-v", on command := onCmd "paste" paste]+ menuLine mnuEdit+ menuItem mnuEdit [text := "&Find...\tCtrl-f", on command := onCmd "justFind" justFind]+ menuItem mnuEdit [text := "&Find Next\tCtrl-g", on command := onCmd "findNext" justFindNext]+ menuItem mnuEdit [text := "&Find Previous\tCtrl-Shift-g", on command := onCmd "findPrev" justFindPrev]+ menuItem mnuEdit [text := "&Replace...\tCtrl-Shift-r", on command := onCmd "findReplace" findReplace]++ mnuHask <- menuPane [text := "Haskell"]+ menuItem mnuHask [text := "&Load modules...\tCtrl-l", on command := onCmd "loadModules" loadModules]+ menuItem mnuHask [text := "&Load modules by name...\tCtrl-Shift-l",+ on command := onCmd "loadModulesByName" loadModulesByName]+ mitReload <- menuItem mnuHask [text := "&Reload\tCtrl-r", on command := onCmd "reloadModules" reloadModules]+ menuLine mnuHask+ menuItem mnuHask [text := "&Value of Expression\tCtrl-e", on command := onCmd "getValue" getValue]+ menuItem mnuHask [text := "&Type of Expression\tCtrl-t", on command := onCmd "getType" getType]+ menuItem mnuHask [text := "&Kind of Expression\tCtrl-k", on command := onCmd "getKind" getKind]+ + mnuHelp <- menuHelp []+ menuAbout mnuHelp [on command := infoDialog win "About hPage" "Author: Fernando Brujo Benavides"]+ + set win [menuBar := [mnuPage, mnuEdit, mnuHask, mnuHelp]]+ + -- Tool bar...+ tbMain <- toolBarEx win True True []+ newPath <- imageFile "new.png"+ openPath <- imageFile "open.png"+ savePath <- imageFile "save.png"+ cutPath <- imageFile "cut.png"+ copyPath <- imageFile "copy.png"+ pastePath <- imageFile "paste.png"+ reloadPath <- imageFile "reload.png"+ toolMenu tbMain mitNew "New" newPath [tooltip := "New"]+ toolMenu tbMain mitOpen "Open" openPath [tooltip := "Open"]+ toolMenu tbMain mitSave "Save" savePath [tooltip := "Save"]+ toolMenu tbMain mitCut "Cut" cutPath [tooltip := "Cut"]+ toolMenu tbMain mitCopy "Copy" copyPath [tooltip := "Copy"]+ toolMenu tbMain mitPaste "Paste" pastePath [tooltip := "Paste"]+ toolMenu tbMain mitReload "Reload" reloadPath [tooltip := "Reload Modules"]+ + -- Layout settings+ let txtCodeL = fill $ widget txtCode+ lstPagesL = fill $ boxed "Pages" $ fill $ widget lstPages+ lstModulesL = fill $ boxed "Modules" $ fill $ widget lstModules+ valueRowL = [widget btnGetValue, hfill $ widget txtValue]+ typeRowL = [widget btnGetType, hfill $ widget txtType]+ kindRowL = [widget btnGetKind, hfill $ widget txtKind]+ resultsGridL= hfill $ boxed "Expression" $ grid 5 0 [valueRowL, typeRowL, kindRowL]+ leftL = container pnlL $ column 5 [lstPagesL, lstModulesL]+ rightL = container pnlR $ column 5 [txtCodeL, resultsGridL]+ set win [layout := container pnl $ fill $ vsplit splLR 7 400 leftL rightL,+ clientSize := sz 800 600]++ -- ...and RUN!+ refreshPage model guiCtx+ focusOn txtCode++-- EVENT HANDLERS --------------------------------------------------------------+refreshPage, savePageAs, savePage, openPage,+ pageChange, copy, cut, paste,+ justFind, justFindNext, justFindPrev, findReplace,+ restartTimer, killTimer,+ getValue, getType, getKind,+ loadModules, loadModulesByName, reloadModules :: HPS.ServerHandle -> GUIContext -> IO ()++getValue model guiCtx@GUICtx{guiResults = GUIRes{resValue = grrValue}} =+ runTxtHP HP.valueOf' model guiCtx grrValue++getType model guiCtx@GUICtx{guiResults = GUIRes{resType = grrType}} =+ runTxtHP HP.typeOf' model guiCtx grrType++getKind model guiCtx@GUICtx{guiResults = GUIRes{resKind = grrKind}} =+ runTxtHP HP.kindOf' model guiCtx grrKind++pageChange model guiCtx@GUICtx{guiPages = lstPages} =+ do+ i <- get lstPages selection+ case i of+ (-1) -> return ()+ _ -> runHP' (HP.setPageIndex i) model guiCtx++openPage model guiCtx@GUICtx{guiWin = win,+ guiStatus = status} =+ do+ fileNames <- filesOpenDialog win True True "Open file..." [("Haskells",["*.hs"]),+ ("Any file",["*.*"])] "" ""+ case fileNames of+ [] ->+ return ()+ fs ->+ do+ set status [text := "opening..."]+ flip mapM_ fs $ \f -> runHP' (HP.openPage f) model guiCtx++savePageAs model guiCtx@GUICtx{guiWin = win, guiStatus = status} =+ do+ fileName <- fileSaveDialog win True True "Save file..." [("Haskells",["*.hs"]),+ ("Any file",["*.*"])] "" ""+ case fileName of+ Nothing ->+ return ()+ Just f ->+ do+ set status [text := "saving..."]+ runHP' (HP.savePageAs f) model guiCtx++savePage model guiCtx@GUICtx{guiWin = win} =+ do+ maybePath <- tryIn' model HP.getPagePath+ case maybePath of+ Left err ->+ warningDialog win "Error" err+ Right Nothing ->+ savePageAs model guiCtx+ Right _ ->+ do+ set (guiStatus guiCtx) [text := "saving..."]+ runHP' HP.savePage model guiCtx++copy _model GUICtx{guiCode = txtCode} = textCtrlCopy txtCode++cut model guiCtx@GUICtx{guiCode = txtCode} = textCtrlCut txtCode >> refreshPage model guiCtx++paste model guiCtx@GUICtx{guiCode = txtCode} = textCtrlPaste txtCode >> refreshPage model guiCtx++justFind model guiCtx = openFindDialog model guiCtx "Find..." dialogDefaultStyle++justFindNext model guiCtx@GUICtx{guiSearch = search} =+ do+ curFlags <- findReplaceDataGetFlags search+ findReplaceDataSetFlags search $ curFlags .|. wxFR_DOWN+ findNextButton model guiCtx++justFindPrev model guiCtx@GUICtx{guiSearch = search} =+ do+ curFlags <- findReplaceDataGetFlags search+ findReplaceDataSetFlags search $ curFlags .&. complement wxFR_DOWN+ findNextButton model guiCtx++findReplace model guiCtx = openFindDialog model guiCtx "Find and Replace..." $ dialogDefaultStyle .|. wxFR_REPLACEDIALOG+ +reloadModules = runHP HP.reloadModules++loadModules model guiCtx@GUICtx{guiWin = win, guiStatus = status} =+ do+ fileNames <- filesOpenDialog win True True "Load Module..." [("Haskell Modules",["*.hs"])] "" ""+ case fileNames of+ [] ->+ return ()+ fs ->+ do+ set status [text := "loading..."]+ runHP (HP.loadModules fs) model guiCtx++loadModulesByName model guiCtx@GUICtx{guiWin = win, guiStatus = status} =+ do+ moduleNames <- textDialog win "Enter the module names, separated by spaces" "Load Modules..." ""+ case moduleNames of+ "" ->+ return ()+ mns ->+ do+ set status [text := "loading..."]+ runHP (HP.loadModules $ words mns) model guiCtx++refreshPage model guiCtx@GUICtx{guiWin = win,+ guiPages = lstPages,+ guiModules = lstModules,+ guiCode = txtCode,+ guiStatus = status} =+ do+ res <- tryIn' model $ do+ pc <- HP.getPageCount+ pages <- mapM HP.getPageNthDesc [0..pc-1]+ ind <- HP.getPageIndex+ txt <- HP.getPageText+ lmsRes <- HP.getLoadedModules+ let lms = case lmsRes of+ Left _ -> []+ Right x -> x+ return (lms, pages, ind, txt)+ case res of+ Left err ->+ warningDialog win "Error" err+ Right (ms, ps, i, t) ->+ do+ -- Refresh the pages list+ itemsDelete lstPages+ (flip mapM) ps $ \pd ->+ let prefix = if HP.pIsModified pd+ then "*"+ else ""+ name = case HP.pPath pd of+ Nothing -> "new page"+ Just fn -> takeFileName $ dropExtension fn+ in itemAppend lstPages $ prefix ++ name+ set lstPages [selection := i]+ -- Refresh the modules list+ itemsDelete lstModules+ (flip mapM) ms $ itemAppend lstModules+ -- Refresh the current text+ set txtCode [text := t]+ set status [text := ""]+ -- Refresh the current expression box+ refreshExpr model guiCtx True++runHP' :: HP.HPage () -> HPS.ServerHandle -> GUIContext -> IO ()+runHP' a = runHP $ a >>= return . Right++runHP :: HP.HPage (Either HP.InterpreterError ()) -> HPS.ServerHandle -> GUIContext -> IO ()+runHP hpacc model guiCtx@GUICtx{guiWin = win} =+ do+ res <- tryIn model hpacc+ case res of+ Left err ->+ warningDialog win "Error" err+ Right () ->+ refreshPage model guiCtx++runTxtHP :: HP.HPage (MVar (Either HP.InterpreterError String)) -> + HPS.ServerHandle -> GUIContext -> GUIResultRow -> IO ()+runTxtHP hpacc model guiCtx@GUICtx{guiWin = win,+ guiStatus = status}+ GUIRRow{grrButton = btn,+ grrText = txtBox} =+ do+ refreshExpr model guiCtx False+ res <- tryIn' model hpacc+ case res of+ Left err -> warningDialog win "Error" err+ Right var -> do+ cancelled <- varCreate False+ prevOnCmd <- get btn $ on command+ prevText <- get btn text+ let prevAttrs = [text := prevText,+ on command := prevOnCmd]+ set btn [text := "Cancel",+ on command := cancelHP model cancelled]+ set txtBox [enabled := False]+ set status [text := "processing..."]+ spawn . liftIO $ do+ val <- readMVar var+ wasCancelled <- varGet cancelled+ if wasCancelled+ then+ set status [text := "cancelled"]+ else+ do+ set status [text := "ready"]+ case val of+ Left err -> warningDialog win "Error" $ HP.prettyPrintError err+ Right txt -> set txtBox [text := txt]+ set txtBox [enabled := True]+ set btn prevAttrs+ return ()++cancelHP :: HPS.ServerHandle -> Var Bool -> IO ()+cancelHP model cancelled = varSet cancelled True >> tryIn' model HP.cancel >> return () ++refreshExpr :: HPS.ServerHandle -> GUIContext -> Bool -> IO ()+refreshExpr model guiCtx@GUICtx{guiResults = GUIRes{resValue = grrValue,+ resType = grrType,+ resKind = grrKind},+ guiCode = txtCode,+ guiWin = win} forceClear =+ do+ txt <- get txtCode text+ ip <- textCtrlGetInsertionPoint txtCode+ + res <- tryIn' model $ HP.setPageText txt ip+ + case res of+ Left err ->+ warningDialog win "Error" err+ Right changed ->+ if changed || forceClear+ then mapM_ (flip set [text := ""] . grrText) [grrValue, grrType, grrKind]+ else debugIO "dummy refreshExpr"+ + killTimer model guiCtx+++-- TIMER HANDLERS --------------------------------------------------------------+restartTimer model guiCtx@GUICtx{guiWin = win, guiTimer = varTimer} =+ do+ newRefreshTimer <- timer win [interval := 1000,+ on command := refreshExpr model guiCtx False]+ refreshTimer <- varSwap varTimer newRefreshTimer+ timerOnCommand refreshTimer $ return ()++killTimer _model GUICtx{guiWin = win, guiTimer = varTimer} =+ do+ -- kill the timer till there's new notices+ newRefreshTimer <- timer win [interval := 1000000, on command := debugIO "Inactivity detected"]+ refreshTimer <- varSwap varTimer newRefreshTimer+ timerOnCommand refreshTimer $ return ()++-- INTERNAL UTILS --------------------------------------------------------------+type ErrorString = String++tryIn' :: HPS.ServerHandle -> HP.HPage x -> IO (Either ErrorString x)+tryIn' model hpacc = tryIn model $ hpacc >>= return . Right++tryIn :: HPS.ServerHandle -> HP.HPage (Either HP.InterpreterError x) -> IO (Either ErrorString x)+tryIn model hpacc =+ do+ res <- HPS.runIn model $ catchError (hpacc >>= return . Right)+ (\ioerr -> return $ Left ioerr)+ case res of+ Left err -> do+ errorIO err+ return . Left $ ioeGetErrorString err+ Right (Left err) -> return . Left $ HP.prettyPrintError err+ Right (Right val) -> return . Right $ val++-- FIND/REPLACE UTILS ----------------------------------------------------------+data FRFlags = FRFlags {frfGoingDown :: Bool,+ frfMatchCase :: Bool,+ frfWholeWord :: Bool,+ frfWrapSearch :: Bool}+ deriving (Eq, Show)++buildFRFlags :: Bool -> Int -> IO FRFlags+buildFRFlags w x = return FRFlags {frfGoingDown = (x .&. wxFR_DOWN) /= 0,+ frfMatchCase = (x .&. wxFR_MATCHCASE) /= 0,+ frfWholeWord = (x .&. wxFR_WHOLEWORD) /= 0,+ frfWrapSearch = w}++openFindDialog :: HPS.ServerHandle -> GUIContext -> String -> Int -> IO ()+openFindDialog model guiCtx@GUICtx{guiWin = win,+ guiSearch = search} title dlgStyle =+ do+ frdialog <- findReplaceDialogCreate win search title $ dlgStyle + wxFR_NOWHOLEWORD+ let winSet k f = let hnd _ = f model guiCtx >> propagateEvent+ in windowOnEvent frdialog [k] hnd hnd+ winSet wxEVT_COMMAND_FIND findNextButton+ winSet wxEVT_COMMAND_FIND_NEXT findNextButton+ winSet wxEVT_COMMAND_FIND_REPLACE findReplaceButton+ winSet wxEVT_COMMAND_FIND_REPLACE_ALL findReplaceAllButton+ set frdialog [visible := True]++findNextButton, findReplaceButton, findReplaceAllButton :: HPS.ServerHandle -> GUIContext -> IO ()+findNextButton model guiCtx@GUICtx{guiCode = txtCode,+ guiWin = win,+ guiSearch = search} =+ do+ s <- findReplaceDataGetFindString search+ fs <- findReplaceDataGetFlags search >>= buildFRFlags True+ mip <- findMatch s fs txtCode+ debugIO ("find/next", s, fs, mip)+ case mip of+ Nothing ->+ infoDialog win "Find Results" $ s ++ " not found."+ Just ip ->+ do+ textCtrlSetSelection txtCode (length s + ip) ip+ refreshExpr model guiCtx False ++findReplaceButton model guiCtx@GUICtx{guiCode = txtCode,+ guiWin = win,+ guiSearch = search} =+ do+ s <- findReplaceDataGetFindString search+ r <- findReplaceDataGetReplaceString search+ fs <- findReplaceDataGetFlags search >>= buildFRFlags True+ mip <- findMatch s fs txtCode+ debugIO ("replace", s, r, fs, mip)+ case mip of+ Nothing ->+ infoDialog win "Find Results" $ s ++ " not found."+ Just ip ->+ do+ textCtrlReplace txtCode ip (length s + ip) r+ textCtrlSetSelection txtCode (length r + ip) ip+ refreshExpr model guiCtx False+ +findReplaceAllButton _model GUICtx{guiCode = txtCode,+ guiSearch = search} =+ do+ s <- findReplaceDataGetFindString search+ r <- findReplaceDataGetReplaceString search + fs <- findReplaceDataGetFlags search >>= buildFRFlags False+ debugIO ("all", s, r, fs)+ textCtrlSetInsertionPoint txtCode 0+ unfoldM_ $ do+ mip <- findMatch s fs txtCode+ case mip of+ Nothing ->+ return mip+ Just ip ->+ do+ textCtrlReplace txtCode ip (length s + ip) r+ textCtrlSetInsertionPoint txtCode $ length r + ip+ return mip+ +findMatch :: String -> FRFlags -> TextCtrl () -> IO (Maybe Int)+findMatch query flags txtCode =+ do+ txt <- get txtCode text+ ip <- textCtrlGetInsertionPoint txtCode+ let (substring, string) = if frfMatchCase flags+ then (query, txt)+ else (map toLower query, map toLower txt)+ funct = if frfGoingDown flags+ then nextMatch (ip + 1)+ else prevMatch ip+ (mip, wrapped) = funct substring string+ return $ if (not $ frfWrapSearch flags) && wrapped+ then Nothing+ else mip+ ++prevMatch, nextMatch :: Int -> String -> String -> (Maybe Int, Bool)+prevMatch _ [] _ = (Nothing, True) -- When looking for nothing, that's what you get+prevMatch from substring string | length string < from || from <= 0 = prevMatch (length string) substring string+ | otherwise =+ case nextMatch (fromBack from) (reverse substring) (reverse string) of+ (Nothing, wrapped) -> (Nothing, wrapped)+ (Just ri, wrapped) -> (Just $ fromBack (ri + length substring), wrapped)+ where fromBack x = length string - x++nextMatch _ [] _ = (Nothing, True) -- When looking for nothing, that's what you get+nextMatch from substring string | length substring > length string = (Nothing, True)+ | length string <= from = nextMatch 0 substring string+ | otherwise =+ let after = drop from string+ before = take (from + length substring) string+ aIndex = indexOf substring after+ bIndex = indexOf substring before+ in case aIndex of+ Just ai ->+ (Just $ from + ai, False)+ Nothing ->+ case bIndex of+ Nothing -> (Nothing, True)+ Just bi -> (Just bi, True)+ +indexOf :: String -> String -> Maybe Int+indexOf substring string = findIndex (isPrefixOf substring) $ tails string
+ src/HPage/Server.hs view
@@ -0,0 +1,39 @@++module HPage.Server (+ start, stop, runIn, ServerHandle+ ) where++import Control.Monad+import Control.Monad.Trans+import Control.Monad.Loops+import Control.Concurrent.Process+import HPage.Control+import Utils.Log++newtype ServerHandle = SH {handle :: Handle (Either Stop (HPage ()))}++data Stop = Stop++start :: IO ServerHandle+start = (spawn $ makeProcess evalHPage pageRunner) >>= return . SH+ where pageRunner = iterateWhile id $ do+ liftTraceIO "hps iterating..."+ v <- recv+ case v of+ Left Stop ->+ do+ liftTraceIO "hps stop"+ return False+ Right acc ->+ do+ liftTraceIO "hps continue"+ lift acc >> return True++runIn :: ServerHandle -> HPage a -> IO a+runIn server action = runHere $ do+ me <- self+ sendTo (handle server) $ Right $ action >>= sendTo me+ recv++stop :: ServerHandle -> IO ()+stop server = sendTo (handle server) $ Left Stop
+ src/HPage/Test/Server.hs view
@@ -0,0 +1,900 @@+module HPage.Test.Server where++import Data.Char+import GHC.IOBase+import Control.Monad.Error+import Test.QuickCheck+import Test.QuickCheck.Batch+import qualified HPage.Control as HP+import qualified HPage.Server as HPS+import qualified Language.Haskell.Interpreter as Hint+import qualified Language.Haskell.Interpreter.Server as HS+import System.Directory+import Control.Monad.Loops+import qualified Data.ByteString.Char8 as Str+import Utils.Log++instance Arbitrary Char where+ arbitrary = elements (['A'..'Z'] ++ ['a' .. 'z'])+ coarbitrary c = variant (ord c `rem` 16)++newtype ModuleName = MN {mnString :: String}+ deriving (Eq)++instance Show ModuleName where+ show = mnString++instance Arbitrary ModuleName where+ arbitrary = do+ s <- arbitrary+ return . MN $ "Test" ++ map toLower s+ coarbitrary _ = undefined++newtype ClassName = CN {cnString :: String}+ deriving (Eq, Show)++instance Arbitrary ClassName where+ arbitrary = elements $ map CN [ "HPage", "IO", "IO a", "Int", "String"]+ coarbitrary _ = undefined++shouldFail :: (MonadError e m) => m a -> m Bool+shouldFail a = (a >> return False) `catchError` (\_ -> return True)++options :: TestOptions+options = TestOptions+ { no_of_tests = 200+ , length_of_tests = 1+ , debug_tests = False }++testDir :: FilePath+testDir = "TestFiles"++main :: IO ()+main =+ do+ createDirectoryIfMissing True testDir+ hps <- HPS.start+ hs <- HS.start+ runTests "Editing" options+ [ run $ prop_setget_text hps+ , run $ prop_setget_expr hps+ , run $ prop_setget_expr_fail hps+ , run $ prop_addrem_expr hps+ , run $ prop_addrem_expr_fail hps+ , run $ prop_setget_nth hps+ , run $ prop_setget_nth_fail hps+ , run $ prop_remove_nth hps+ , run $ prop_remove_nth_fail hps+ , run $ prop_undoredo hps+ ]+ runTests "Many Pages" options+ [ run $ prop_new_page hps+ , run $ prop_open_page hps+ , run $ prop_open_page_fail hps+ , run $ prop_setget_page hps+ , run $ prop_set_page_index_fail hps+ , run $ prop_save_page hps+ , run $ prop_save_page_fail hps+ , run $ prop_save_page_as hps+ , run $ prop_close_page hps+ , run $ prop_is_modified_page hps+ , run $ prop_save_nth_page hps+ , run $ prop_save_nth_page_fail hps+ , run $ prop_save_nth_page_as hps+ , run $ prop_save_nth_page_as_fail hps+ , run $ prop_is_modified_nth_page hps+ , run $ prop_is_modified_nth_page_fail hps+ , run $ prop_close_nth_page hps+ , run $ prop_close_nth_page_fail hps+ , run $ prop_close_all_pages hps+ ]+ runTests "Many Pages (Safe)" options+ [ run $ prop_safe_save_page_as hps+ , run $ prop_safe_close_page hps+ , run $ prop_safe_save_nth_page_as hps+ , run $ prop_safe_close_nth_page hps+ , run $ prop_safe_close_all_pages hps+ ]+ runTests "Named Expressions vs. Hint Server" options+ [ run $ prop_let_fail hps hs+ , run $ prop_let_valueOf hps hs+ , run $ prop_let_typeOf hps hs+ ]+ runTests "vs. Hint Server" options+ [ run $ prop_fail hps hs+ , run $ prop_valueOf hps hs+ , run $ prop_typeOf hps hs+ , run $ prop_kindOf hps hs+ , run $ prop_load_module hps hs+ , run $ prop_reload_modules hps hs+ , run $ prop_get_loaded_modules hps hs+ ]+ runTests "Cancelation" options+ [ run $ prop_sequential hps+ , run $ prop_cancel_load hps+ ]+ removeDirectoryRecursive testDir+ +instance Eq (Hint.InterpreterError) where+ a == b = show a == show b++prop_valueOf :: HPS.ServerHandle -> HS.ServerHandle -> String -> Bool+prop_valueOf hps hs txt =+ unsafePerformIO $ do+ let expr = "length \"" ++ txt ++ "\"" + hpsr <- HPS.runIn hps $ HP.setPageText expr 0 >> HP.valueOf+ hsr <- HS.runIn hs $ Hint.eval expr+ return $ hpsr == hsr++prop_typeOf :: HPS.ServerHandle -> HS.ServerHandle -> String -> Property+prop_typeOf hps hs txt = txt /= "" ==>+ unsafePerformIO $ do+ let h = head txt+ let expr = if isNumber h then [h, h] else "\"" ++ txt ++ "\""+ hpsr <- HPS.runIn hps $ HP.setPageText expr 0 >> HP.typeOf+ hsr <- HS.runIn hs $ Hint.typeOf expr+ return $ hpsr == hsr++prop_kindOf :: HPS.ServerHandle -> HS.ServerHandle -> ClassName -> Bool+prop_kindOf hps hs (CN expr) =+ unsafePerformIO $ do+ hpsr <- HPS.runIn hps $ HP.setPageText expr 0 >> HP.kindOf+ hsr <- HS.runIn hs $ Hint.kindOf expr+ return $ hpsr == hsr++prop_fail :: HPS.ServerHandle -> HS.ServerHandle -> String -> Bool+prop_fail hps hs txt =+ unsafePerformIO $ do+ let expr = "lenggth \"" ++ txt ++ "\""+ Left hpsr <- HPS.runIn hps $ HP.setPageText expr 0 >> HP.valueOf+ Left hsr <- HS.runIn hs $ Hint.eval expr+ return $ hsr == hpsr+ +prop_load_module :: HPS.ServerHandle -> HS.ServerHandle -> ModuleName -> Bool+prop_load_module hps hs mn =+ unsafePerformIO $ do+ let mname = testDir ++ "." ++ show mn+ let ftxt = "module " ++ mname ++ " where v = 32"+ let f2txt = "v = \"" ++ show mn ++ "\""+ hpsr <- HPS.runIn hps $ do+ -- Save TestFiles/Test...hs+ HP.setPageText ftxt 0+ HP.savePageAs $ testDir ++ "/" ++ show mn ++ ".hs"+ -- Save TestFiles/test.hs+ HP.setPageText f2txt 0+ HP.savePageAs $ testDir ++ "/test.hs"+ -- Load TestFiles/test.hs by path+ HP.loadModules [testDir ++ "/test.hs"]+ HP.setPageText "v" 0+ fv <- HP.valueOf+ fm <- HP.getLoadedModules+ -- Load TestFiles/Test...hs by name+ HP.loadModules [mname]+ HP.setPageText "v" 0+ sv <- HP.valueOf+ sm <- HP.getLoadedModules+ return (fv, sv, fm, sm)+ Right hsr <- HS.runIn hs $ do+ Hint.loadModules [testDir ++ "/test.hs"]+ Hint.getLoadedModules >>= Hint.setTopLevelModules+ fv <- Hint.eval "v"+ fm <- Hint.getLoadedModules+ Hint.loadModules [mname]+ Hint.getLoadedModules >>= Hint.setTopLevelModules+ sv <- Hint.eval "v"+ sm <- Hint.getLoadedModules+ return (Right fv, Right sv, Right fm, Right sm)+ -- liftDebugIO (hpsr, hsr)+ return $ hpsr == hsr++prop_reload_modules :: HPS.ServerHandle -> HS.ServerHandle -> String -> Bool+prop_reload_modules hps hs txt =+ unsafePerformIO $ do+ let expr = "test = show \"" ++ txt ++ "\"" + hpsr <- HPS.runIn hps $ do+ HP.setPageText expr 0+ HP.savePageAs $ testDir ++ "/test.hs"+ HP.setPageText "test" 0+ HP.loadModules [testDir ++ "/test.hs"]+ HP.reloadModules+ HP.valueOf+ hsr <- HS.runIn hs $ do+ Hint.loadModules [testDir ++ "/test.hs"]+ Hint.getLoadedModules >>= Hint.setTopLevelModules+ Hint.eval "test"+ return $ hpsr == hsr+ +prop_get_loaded_modules :: HPS.ServerHandle -> HS.ServerHandle -> ModuleName -> Bool+prop_get_loaded_modules hps hs mn =+ unsafePerformIO $ do+ let expr1 = "ytest = show \"" ++ show mn ++ "\""+ let expr2 = "module " ++ testDir ++ ".XX" ++ show mn ++ "2 where import " ++ testDir ++ ".XX" ++ show mn ++ "3; xtest = show \"" ++ show mn ++ "\""+ let expr3 = "module " ++ testDir ++ ".XX" ++ show mn ++ "3 where xfact = (1,2,3)"+ let mnf1 = testDir ++ "/XX" ++ (show mn) ++ "1.hs"+ let mnf2 = testDir ++ "/XX" ++ (show mn) ++ "2.hs"+ let mnf3 = testDir ++ "/XX" ++ (show mn) ++ "3.hs"+ HPS.runIn hps $ do+ HP.setPageText expr1 0+ HP.savePageAs mnf1+ HP.setPageText expr2 0+ HP.savePageAs mnf2+ HP.setPageText expr3 0+ HP.savePageAs mnf3+ hpsr1 <- HPS.runIn hps $ HP.loadModules [mnf1] >> HP.getLoadedModules+ hsr1 <- HS.runIn hs $ Hint.loadModules [mnf1] >> Hint.getLoadedModules+ hpsr2 <- HPS.runIn hps $ HP.loadModules [mnf2] >> HP.getLoadedModules+ hsr2 <- HS.runIn hs $ Hint.loadModules [mnf2] >> Hint.getLoadedModules+ hpsr3 <- HPS.runIn hps $ HP.loadModules [mnf3] >> HP.getLoadedModules+ hsr3 <- HS.runIn hs $ Hint.loadModules [mnf3] >> Hint.getLoadedModules+ --liftDebugIO [(hpsr1, hpsr2, hpsr3), (hsr1, hsr2, hsr3)]+ return $ (hpsr1, hpsr2, hpsr3) == (hsr1, hsr2, hsr3)+ +prop_sequential :: HPS.ServerHandle -> String -> Bool+prop_sequential hps txt =+ unsafePerformIO $ do+ let expr = "test = \"" ++ txt ++ "\""+ HPS.runIn hps $ do+ HP.setPageText expr 0+ HP.savePageAs $ testDir ++ "/test.hs"+ HP.loadModules' [testDir ++ "/test.hs"]+ Right hpsr <- HPS.runIn hps $ do+ HP.setPageText "test" 0+ HP.valueOf+ return $ hpsr == show txt++prop_cancel_load :: HPS.ServerHandle -> ModuleName -> Bool+prop_cancel_load hps mn =+ unsafePerformIO $ do+ let expr1 = "module " ++ show mn ++ " where cancelLoadTest = (1,2,3)"+ let expr2 = "module " ++ show mn ++ "2 where cancelLoadTest = foldl (*) 1 [1.." ++ show (length $ show mn) ++ "]"+ HPS.runIn hps $ do+ HP.reset+ HP.setPageText expr2 0+ HP.savePageAs $ testDir ++ "/" ++ show mn ++ "2.hs"+ HP.setPageText expr1 0+ HP.savePageAs $ testDir ++ "/" ++ show mn ++ ".hs"+ HP.setPageText "cancelLoadTest" 0+ HP.loadModules [testDir ++ "/" ++ show mn ++ ".hs"]+ oldMs <- HP.getLoadedModules+ oldRes <- HP.valueOf+ oldCtx <- HP.ctxString+ HP.loadModules' [testDir ++ "/" ++ show mn ++ "2.hs"]+ HP.cancel+ newMs <- HP.getLoadedModules+ newRes <- HP.valueOf+ newCtx <- HP.ctxString+ -- liftDebugIO [(oldRes, oldMs, oldCtx), (newRes, newMs, newCtx)]+ return $ (oldRes, oldMs, oldCtx) == (newRes, newMs, newCtx)++prop_setget_text :: HPS.ServerHandle -> String -> Bool+prop_setget_text hps txt =+ unsafePerformIO $ HPS.runIn hps $ do+ HP.setPageText txt 0+ HP.getPageText >>= return . (txt ==)++prop_setget_expr :: HPS.ServerHandle -> String -> Property+prop_setget_expr hps txt =+ txt /= "" ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.setPageText (txt ++ "\n\nxx") (length txt + 3)+ exi1 <- HP.getExprIndex+ exp1 <- HP.getExprText+ HP.setExprIndex 0+ exi0 <- HP.getExprIndex+ exp0 <- HP.getExprText+ HP.setExprText "yy"+ exi2 <- HP.getExprIndex+ exp2 <- HP.getExprText+ HP.setExprIndex 1+ exi3 <- HP.getExprIndex+ exp3 <- HP.getExprText+ -- liftDebugIO [(exi1, exp1), (exi0, exp0), (exi2, exp2), (exi3, exp3)]+ return $ (exi1 == 1) && (exp1 == "xx") &&+ (exi0 == 0) && (exp0 == txt) &&+ (exi2 == 0) && (exp2 == "yy") &&+ (exi3 == 1) && (exp3 == "xx")++prop_setget_expr_fail :: HPS.ServerHandle -> String -> Bool+prop_setget_expr_fail hps _ =+ unsafePerformIO $ HPS.runIn hps $ shouldFail $ HP.clearPage >> HP.getExprText++prop_addrem_expr :: HPS.ServerHandle -> String -> Property+prop_addrem_expr hps txt =+ txt /= "" ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.clearPage+ HP.addExpr txt+ exi1 <- HP.getExprIndex+ exp1 <- HP.getExprText+ HP.removeExpr+ exi0 <- HP.getExprIndex+ exp0 <- HP.getPageText+ HP.addExpr txt+ HP.addExpr txt+ exi2 <- HP.getExprIndex+ exp2 <- HP.getExprText+ HP.removeExpr+ exi3 <- HP.getExprIndex+ exp3 <- HP.getPageText+ -- liftDebugIO [(exi1, exp1), (exi0, exp0), (exi2, exp2), (exi3, exp3)]+ return $ (exi1 == 0) && (exp1 == txt) &&+ (exi0 == -1) && (exp0 == "") &&+ (exi2 == 1) && (exp2 == txt) &&+ (exi3 == 0) && (exp3 == txt)++prop_addrem_expr_fail :: HPS.ServerHandle -> String -> Bool+prop_addrem_expr_fail hps _ =+ unsafePerformIO $ HPS.runIn hps $ shouldFail $ HP.clearPage >> HP.removeExpr++prop_setget_nth :: HPS.ServerHandle -> Int -> Property+prop_setget_nth hps i =+ i >= 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.clearPage+ replicateM (i+1) $ HP.addExpr "ww"+ exp0 <- HP.getExprNthText 0+ exp1 <- HP.getExprNthText i+ HP.setExprNthText i "xxx"+ exp2 <- HP.getExprNthText i+ HP.setExprNthText i "x\n\ny"+ exp3 <- HP.getExprNthText $ i+1+ -- liftDebugIO [exp0, exp1, exp2, exp3]+ return $ (exp1 == "ww") &&+ (exp0 == "ww") &&+ (exp2 == "xxx") &&+ (exp3 == "y")++prop_setget_nth_fail :: HPS.ServerHandle -> Int -> String -> Property+prop_setget_nth_fail hps i txt =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.clearPage+ set <- shouldFail $ HP.setExprNthText i txt+ get <- shouldFail $ HP.getExprNthText i+ -- liftDebugIO (get, set)+ return (set && get)++prop_remove_nth :: HPS.ServerHandle -> Int -> Property+prop_remove_nth hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.clearPage+ forM [0..i] $ HP.addExpr . show+ HP.removeNth 0+ exp0 <- HP.getExprNthText 0+ forM [i-2,i-3..0] $ HP.removeNth+ exp1 <- HP.getPageText+ -- liftDebugIO [exp0, exp1]+ return $ (exp0 == "1") &&+ (exp1 == show i)++prop_remove_nth_fail :: HPS.ServerHandle -> Int -> Property+prop_remove_nth_fail hps i =+ i >= 0 ==>+ unsafePerformIO $ HPS.runIn hps $ HP.clearPage >> shouldFail (HP.removeNth $ i+1)+++prop_undoredo :: HPS.ServerHandle -> String -> Property+prop_undoredo hps txt =+ txt /= "" ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.addPage+ b0 <- HP.getPageText+ HP.setPageText txt 0+ b1 <- HP.getPageText+ HP.addExpr "xx"+ b2 <- HP.getPageText+ HP.addExpr "yy"+ b3 <- HP.getPageText+ HP.setExprIndex 1+ b4 <- HP.getPageText+ HP.setExprText $ txt ++ "|" ++ txt+ b5 <- HP.getPageText+ HP.removeExpr+ b6 <- HP.getPageText+ HP.removeNth 0+ b7 <- HP.getPageText+ HP.setExprNthText 0 txt+ b8 <- HP.getPageText+ HP.addExpr "zz"+ b9 <- HP.getPageText+ let to10 = [0..10] :: [Int]+ after <- mapM (\_ -> HP.undo >> HP.getPageText) to10+ redo <- mapM (\_ -> HP.redo >> HP.getPageText) to10+ HP.clearPage >> HP.addExpr "cc" >> HP.clearPage+ c0 <- HP.addExpr "zz" >> HP.getPageText+ c1 <- HP.undo >> HP.getPageText+ c2 <- HP.undo >> HP.getPageText+ c3 <- HP.setPageText "ww" 0 >> HP.getPageText+ c4 <- HP.redo >> HP.getPageText+ let result = ([b8, b7, b6, b5, b4, b3, b2, b1, b0, "", ""] == after) &&+ ([b1, b2, b3, b4, b5, b6, b7, b8, b9, b9, b9] == redo) &&+ ([c0, c1, c2, c3, c4] == ["zz", "", "cc", "ww", "ww"])+ if not result+ then+ do+ liftDebugIO [b8, b7, b6, b5, b4, b3, b2, b1, b0, "", ""]+ liftDebugIO after+ liftDebugIO [b1, b2, b3, b4, b5, b6, b7, b8, b8, b8, b8]+ liftDebugIO redo+ liftDebugIO ["zz", "", "cc", "ww", "ww"]+ liftDebugIO [c0, c1, c2, c3, c4]+ return False+ else+ return True ++prop_new_page :: HPS.ServerHandle -> Int -> Property+prop_new_page hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.clearPage+ HP.closeAllPages+ pc0 <- HP.getPageCount+ pi0 <- HP.getPageIndex+ pt0 <- HP.getPageText+ pss <- (flip mapM) [1..i] $ \x -> do+ HP.addPage+ psc <- HP.getPageCount+ psi <- HP.getPageIndex+ pst <- HP.getPageText+ HP.setPageIndex $ psc - 1+ HP.setPageText ("old "++ show x) 0+ return (x, psc, psi, pst)+ let results = (0,pc0,pi0,pt0):pss+ -- liftDebugIO results+ return $ all (\(k, kc, ki, kt) ->+ kc == k+1 &&+ ki == 0 &&+ kt == "") $ results++prop_open_page, prop_open_page_fail :: HPS.ServerHandle -> String -> Property+prop_open_page hps file =+ file /= "" ==>+ unsafePerformIO $ HPS.runIn hps $ do+ let path = testDir ++ "/Test" ++ file+ Hint.liftIO $ writeFile path file+ HP.closeAllPages+ HP.openPage path+ liftM (file ==) HP.getPageText++prop_open_page_fail hps file =+ file /= "" ==>+ unsafePerformIO $ HPS.runIn hps $ do+ let path = testDir ++ "/NO-Test" ++ file+ HP.closeAllPages+ shouldFail $ HP.openPage path++prop_setget_page, prop_set_page_index_fail :: HPS.ServerHandle -> Int -> Property+prop_setget_page hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.clearPage+ HP.closeAllPages+ HP.setPageText "0" 0+ forM [1..i] $ \x ->+ do+ HP.addPage+ HP.setPageText (show x) 0 + pc <- HP.getPageCount+ pss <- (flip mapM) [0..i] $ \x -> do+ HP.setPageIndex (i-x)+ psi <- HP.getPageIndex+ pst <- HP.getPageText+ HP.setPageText ("old "++ show x) 0+ return (x, psi, pst)+ -- liftDebugIO pss+ return . ((pc == i+1) &&) $ all (\(k, ki, kt) ->+ ki == (i-k) &&+ kt == show k) $ pss+prop_set_page_index_fail hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ replicateM (i-1) HP.addPage+ shouldFail $ HP.setPageIndex i++prop_save_page, prop_save_page_fail, prop_save_page_as :: HPS.ServerHandle -> String -> Property+prop_save_page hps file =+ file /= "" ==>+ unsafePerformIO $ HPS.runIn hps $ do+ let path = testDir ++ "/Test" ++ file+ Hint.liftIO $ writeFile path file+ HP.closeAllPages+ HP.openPage path+ HP.savePage+ p1 <- HP.getPageText+ HP.openPage path+ p2 <- HP.getPageText+ HP.addExpr file+ HP.savePage+ p3 <- HP.getPageText+ return $ p1 == file &&+ p2 == file &&+ p3 == (file ++ "\n\n" ++ file)+prop_save_page_fail hps file =+ file /= "" ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ shouldFail $ HP.savePage+prop_save_page_as hps file =+ file /= "" ==>+ unsafePerformIO $ HPS.runIn hps $ do+ let path = testDir ++ "/Test" ++ file+ HP.closeAllPages+ HP.setPageText file 0+ HP.savePageAs path+ HP.openPage path+ p0 <- HP.getPageText+ HP.savePage+ HP.openPage path+ p1 <- HP.getPageText+ return $ p0 == file &&+ p1 == file++prop_close_page :: HPS.ServerHandle -> Int -> Property+prop_close_page hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ HP.setPageText (show i) 0+ forM [1..i] $ \x ->+ do+ HP.addPage+ HP.setPageText (show (i-x)) 0 + pcb <- HP.getPageCount+ pss <- (flip mapM) [i,i-1..1] $ \x -> do+ HP.setPageIndex x+ pbi <- HP.getPageIndex+ pbt <- HP.getPageText+ HP.closePage+ pai <- HP.getPageIndex+ pat <- HP.getPageText+ return (x, pbi, pbt, pai, pat)+ pca <- HP.getPageCount+ pia <- HP.getPageIndex+ pta <- HP.getPageText+ HP.closePage+ pcf <- HP.getPageCount+ pif <- HP.getPageIndex+ ptf <- HP.getPageText+ --liftDebugIO (pcb, (pca, pia, pta), (pcf, pif, ptf), pss)+ --let ff = \(k, _, _, _, _) -> (k, k, show k, k-1, show (k-1))+ --liftDebugIO (i+1, (1, 0, "0"), (1, 0, ""), map ff pss)+ return . ((pcb == i+1 &&+ pca == 1 && pia == 0 && pta == "0" &&+ pcf == 1 && pif == 0 && ptf == "") &&) $+ all (\(k, kbi, kbt, kai, kat) ->+ kbi == k &&+ kbt == show k &&+ kai == k-1 &&+ kat == show (k-1) ) $ pss++prop_is_modified_page :: HPS.ServerHandle -> FilePath -> Property+prop_is_modified_page hps file =+ file /= "" ==>+ unsafePerformIO $ HPS.runIn hps $ do+ let path = testDir ++ "/Test" ++ file+ HP.addPage+ f0 <- HP.isModifiedPage+ HP.setPageText file 0+ HP.addExpr file+ t0 <- HP.isModifiedPage+ HP.undo+ t1 <- HP.isModifiedPage+ HP.undo+ f1 <- HP.isModifiedPage+ HP.redo+ t2 <- HP.isModifiedPage+ HP.redo+ t3 <- HP.isModifiedPage+ HP.savePageAs path+ f2 <- HP.isModifiedPage+ HP.undo+ t4 <- HP.isModifiedPage+ HP.addExpr $ file ++ "$$$"+ t5 <- HP.isModifiedPage+ HP.openPage path+ f3 <- HP.isModifiedPage+ HP.redo+ f4 <- HP.isModifiedPage+ let result = not (f0 || f1 || f2 || f3 || f4) &&+ t0 && t1 && t2 && t3 && t4 && t5+ if not result+ then do+ liftDebugIO $ (('F', f0, f1, f2, f3, f4),+ ('T', t0, t1, t2, t3, t4, t5))+ return False+ else+ return True ++prop_save_nth_page, prop_save_nth_page_fail :: HPS.ServerHandle -> Int -> Property+prop_save_nth_page hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ forM [1..i] $ \x ->+ do+ let y = show $ i - x+ path = testDir ++ "/Test" ++ y+ Hint.liftIO $ writeFile path y+ HP.openPage path+ forM [0..i-1] $ \x ->+ do+ HP.setPageText (show x) 0+ HP.savePageNth x+ HP.closeAllPages+ (flip allM) [0..i-1] $ \x ->+ do+ let path = testDir ++ "/Test" ++ show x+ HP.openPage path+ liftM ((show x) ==) $ HP.getPageText+prop_save_nth_page_fail hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ a <- shouldFail $ HP.savePageNth 0+ forM [1..i] $ \_ -> HP.addPage+ b <- (flip allM) [1..i] $ shouldFail . HP.savePageNth+ c <- shouldFail $ HP.savePageNth $ i + 1+ return $ a && b && c++prop_save_nth_page_as, prop_save_nth_page_as_fail :: HPS.ServerHandle -> Int -> Property+prop_save_nth_page_as hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ forM [1..i] $ \x ->+ do+ let y = show $ i - x+ HP.addPage+ HP.setPageText y 0+ forM [0..i-1] $ \x ->+ do+ let path = testDir ++ "/Test" ++ show x+ HP.savePageNthAs x path+ HP.closeAllPages+ (flip allM) [0..i-1] $ \x ->+ do+ let path = testDir ++ "/Test" ++ show x+ HP.openPage path+ liftM ((show x) ==) $ HP.getPageText+prop_save_nth_page_as_fail hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ forM [1..i] $ \_ -> HP.addPage+ a <- shouldFail $ HP.savePageNth $ i + 1+ b <- shouldFail $ HP.savePageNth $ -1+ return $ a && b++prop_is_modified_nth_page, prop_is_modified_nth_page_fail :: HPS.ServerHandle -> Int -> Property+prop_is_modified_nth_page hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ forM [1..i] $ \x ->+ do+ let y = show $ i - x+ HP.addPage+ HP.setPageText y 0+ t0 <- allM HP.isModifiedPageNth [0..i-1]+ f0 <- HP.isModifiedPageNth i + let path = testDir ++ "/Test.page"+ forM [0..i-1] $ flip HP.savePageNthAs $ path+ f1 <- allM HP.isModifiedPageNth [0..i-1]+ return $ t0 && not (f0 || f1)+prop_is_modified_nth_page_fail hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ forM [1..i] $ \_ -> HP.addPage+ a <- shouldFail $ HP.isModifiedPageNth $ i + 1+ b <- shouldFail $ HP.isModifiedPageNth $ -1+ return $ a && b++prop_close_nth_page, prop_close_nth_page_fail :: HPS.ServerHandle -> Int -> Property+prop_close_nth_page hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ forM [1..i] $ \_ -> HP.addPage+ t0 <- (flip allM) [1..i] $ \x ->+ do+ let y = i - x+ HP.closePageNth y+ pgc <- liftM (y+1==) $ HP.getPageCount+ pgi <- liftM (0 ==) $ HP.getPageIndex+ let result = pgc && pgi+ if not result+ then+ do+ liftDebugIO [pgc, pgi]+ return False+ else+ return True+ HP.closeAllPages+ HP.setPageText "two" 0+ HP.addPage+ HP.setPageText "one" 0+ HP.addPage+ HP.setPageText "zero" 0+ HP.setPageIndex 1+ HP.closePageNth 1+ t1 <- liftM ("zero" ==) $ HP.getPageText+ t2 <- liftM (0 ==) $ HP.getPageIndex+ HP.setPageIndex 1+ t3 <- liftM ("two" ==) $ HP.getPageText+ HP.closePageNth 1+ HP.closePageNth 0+ t4 <- liftM ("" ==) $ HP.getPageText+ t5 <- liftM (0 ==) $ HP.getPageIndex+ t6 <- liftM (1 ==) $ HP.getPageCount+ let result = t0 && t1 && t2 && t3 && t4 && t5 && t6+ if not result+ then+ do+ liftDebugIO [t0, t1, t2, t3, t4, t5, t6]+ return False+ else+ return True+prop_close_nth_page_fail hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ forM [1..i] $ \_ -> HP.addPage+ a <- shouldFail $ HP.closePageNth $ i + 1+ b <- shouldFail $ HP.closePageNth $ -1+ return $ a && b++prop_close_all_pages :: HPS.ServerHandle -> Int -> Property+prop_close_all_pages hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ c0 <- HP.getPageCount+ HP.setPageText "not empty" 0+ forM [1..i-1] $ \_ -> HP.addPage+ c1 <- HP.getPageCount+ HP.setPageIndex $ c1 - 1+ HP.closeAllPages+ c2 <- HP.getPageCount+ i2 <- HP.getPageIndex+ t2 <- HP.getPageText+ let result = (c0, c1, c2, i2, t2) == (1, i, 1, 0, "") + if not result+ then+ do+ liftDebugIO (c0, c1, c2, i2, t2)+ return False+ else+ return True++prop_safe_save_page_as :: HPS.ServerHandle -> ModuleName -> Bool+prop_safe_save_page_as hps (MN file) =+ unsafePerformIO $ HPS.runIn hps $ do+ let path = testDir ++ "/" ++ file+ Hint.liftIO $ removeFileMayNotExist path+ HP.closeAllPages+ HP.setPageText file 0+ HP.safeSavePageAs path+ HP.openPage path+ p0 <- HP.getPageText+ p1 <- shouldFail $ HP.safeSavePageAs path+ HP.openPage path+ p2 <- HP.getPageText+ return $ p0 == file && p1 && p2 == file+ where removeFileMayNotExist f = do+ e <- doesFileExist f+ if e then removeFile f else return ()++prop_safe_close_page :: HPS.ServerHandle -> Int -> Property+prop_safe_close_page hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ (flip allM) [1..i] $ \_ ->+ do+ HP.addPage -- To avoid page 0+ HP.addPage+ HP.setPageText (show i) 0+ c0 <- HP.getPageCount+ t1 <- shouldFail $ HP.safeClosePage+ c1 <- HP.getPageCount+ HP.undo+ HP.safeClosePage+ c2 <- HP.getPageCount+ return $ c0 == c1 &&+ c0 == (c2 + 1) &&+ t1++prop_safe_save_nth_page_as :: HPS.ServerHandle -> Int -> Property+prop_safe_save_nth_page_as hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ forM [1..i] $ \x ->+ do+ let y = show $ i - x+ HP.addPage+ HP.setPageText y 0+ let path = testDir ++ "/Test"+ Hint.liftIO $ Str.writeFile path $ Str.pack $ show i+ t0 <- (flip allM) [0..i-1] $ shouldFail . ((flip HP.safeSavePageNthAs) path)+ Hint.liftIO $ removeFile path+ HP.safeSavePageNthAs 0 path+ return t0++prop_safe_close_nth_page :: HPS.ServerHandle -> Int -> Property+prop_safe_close_nth_page hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ forM [1..i] $ \x ->+ do+ let y = show $ i - x+ HP.addPage+ HP.setPageText y 0+ t0 <- allM (shouldFail . HP.safeClosePageNth) [0..i-2]+ HP.addPage+ HP.safeClosePageNth 0+ t1 <- allM HP.isModifiedPageNth [1..i-1]+ return $ t0 && t1++prop_safe_close_all_pages :: HPS.ServerHandle -> Int -> Property+prop_safe_close_all_pages hps i =+ i > 0 ==>+ unsafePerformIO $ HPS.runIn hps $ do+ HP.closeAllPages+ forM [1..i] $ \x ->+ do+ let y = show $ i - x+ HP.addPage+ HP.setPageText y 0+ shouldFail HP.safeCloseAllPages++prop_let_valueOf :: HPS.ServerHandle -> HS.ServerHandle -> String -> Bool+prop_let_valueOf hps hs txt =+ unsafePerformIO $ do+ let expr = "length \"" ++ txt ++ "\""+ (hpsr1, hpsr2) <- HPS.runIn hps $ do+ HP.addPage+ HP.addExpr $ "testL = " ++ expr+ HP.addExpr $ "test2L x = 2 * x"+ HP.addExpr "test2L testL"+ r1 <- HP.valueOf+ HP.addExpr $ "(test2L testL) `div` 2"+ r2 <- HP.valueOf+ return (r1, r2)+ hsr1 <- HS.runIn hs $ Hint.eval $ "2 * " ++ expr+ hsr2 <- HS.runIn hs $ Hint.eval $ expr+ -- liftDebugIO [(hpsr1, hpsr2), (hsr1, hsr2)]+ return $ (hpsr1, hpsr2) == (hsr1, hsr2)++prop_let_typeOf :: HPS.ServerHandle -> HS.ServerHandle -> String -> Property+prop_let_typeOf hps hs txt = txt /= "" ==>+ unsafePerformIO $ do+ let expr = "\"" ++ txt ++ "\""+ (hpsr1, hpsr2) <- HPS.runIn hps $ do+ HP.addPage+ HP.addExpr $ "testL = " ++ expr+ HP.addExpr "testL"+ r1 <- HP.typeOf+ HP.addExpr $ "test2L x = length x"+ HP.addExpr $ "2 * (test2L testL)"+ r2 <- HP.typeOf+ return (r1, r2)+ hsr1 <- HS.runIn hs $ Hint.typeOf expr+ hsr2 <- HS.runIn hs $ Hint.typeOf $ "2 * (length " ++ expr ++ ")"+ -- liftDebugIO [(hpsr1, hpsr2), (hsr1, hsr2)]+ return $ (hpsr1, hpsr2) == (hsr1, hsr2)++prop_let_fail :: HPS.ServerHandle -> HS.ServerHandle -> String -> Bool+prop_let_fail hps hs txt =+ unsafePerformIO $ do+ let expr = "testL x = lenggth x"+ Left hpsr <- HPS.runIn hps $ do+ HP.addPage+ HP.addExpr expr+ HP.addExpr $ "test2L = 2 * (testL \"" ++ txt ++ "\")"+ HP.addExpr $ "test2L / 2"+ HP.valueOf+ Left hsr <- HS.runIn hs $ Hint.eval "lenggth \"\""+ return $ hsr == hpsr
+ src/Language/Haskell/Interpreter/Server.hs view
@@ -0,0 +1,53 @@++module Language.Haskell.Interpreter.Server (+ start, stop, runIn, asyncRunIn, flush, ServerHandle+ ) where++import Control.Concurrent.MVar+import Control.Monad.Error+import Control.Monad.Loops+import Control.Concurrent.Process+import Language.Haskell.Interpreter++newtype ServerHandle = SH {handle :: Handle (Either Stop (InterpreterT IO ()))}++data Stop = Stop++instance MonadInterpreter m => MonadInterpreter (ReceiverT r m) where+ fromSession = lift . fromSession+ modifySessionRef a = lift . (modifySessionRef a)+ runGhc = lift . runGhc ++start :: IO ServerHandle+start = (spawn $ makeProcess runInterpreter interpreter) >>= return . SH+ where interpreter =+ do+ setImports ["Prelude"]+ iterateWhile id $ do+ v <- recv+ case v of+ Left Stop ->+ return False+ Right acc ->+ lift acc >> return True++asyncRunIn :: ServerHandle -> InterpreterT IO a -> IO (MVar (Either InterpreterError a))+asyncRunIn server action = do+ resVar <- liftIO newEmptyMVar+ sendTo (handle server) $ Right $ try action >>= liftIO . putMVar resVar+ return resVar++runIn :: ServerHandle -> InterpreterT IO a -> IO (Either InterpreterError a)+runIn server action = runHere $ do+ me <- self+ sendTo (handle server) $ Right $ try action >>= sendTo me+ recv++flush :: ServerHandle -> IO (Either InterpreterError ())+flush server = runIn server $ return ()++try :: InterpreterT IO b -> InterpreterT IO (Either InterpreterError b)+try a = (a >>= return . Right) `catchError` (return . Left)++stop :: ServerHandle -> IO ()+stop server = sendTo (handle server) $ Left Stop
+ src/Language/Haskell/Interpreter/Utils.hs view
@@ -0,0 +1,14 @@++module Language.Haskell.Interpreter.Utils (prettyPrintError) where++import Language.Haskell.Interpreter++prettyPrintError :: InterpreterError -> String+prettyPrintError (WontCompile ghcerr) = "Can't compile: " ++ (joinWith "\n" $ map errMsg ghcerr)+prettyPrintError (UnknownError errStr) = "Unknown Error: " ++ errStr+prettyPrintError (NotAllowed errStr) = "Not Allowed Action: " ++ errStr+prettyPrintError (GhcException errStr) = errStr++joinWith :: [a] -> [[a]] -> [a]+joinWith _ [] = []+joinWith sep (x:xs) = x ++ (concat . map (sep ++) $ xs)
+ src/Main.hs view
@@ -0,0 +1,8 @@++module Main where++import Graphics.UI.WX+import HPage.GUI.FreeTextWindow++main :: IO ()+main = start gui
+ src/Utils/Log.hs view
@@ -0,0 +1,37 @@++module Utils.Log where++import Control.Monad.Trans++data LogLevel = Trace | Debug | Info | Warning | Error | Fatal+ deriving (Show, Eq)++logIO :: Show a => LogLevel -> a -> IO ()+logIO lvl msg = putStrLn $ (show lvl) ++ ": " ++ (show msg)++liftLogIO :: (MonadIO m, Show a) => LogLevel -> a -> m ()+liftLogIO 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 ()++traceIO = logIO Trace+debugIO = logIO Debug+{- without log...+traceIO _ = return ()+debugIO _ = return ()+-}+infoIO = logIO Info+warnIO = logIO Warning+errorIO = logIO Error+fatalIO = logIO Fatal++{- with log...+liftTraceIO = liftLogIO Trace+-}+liftTraceIO _ = return ()+liftDebugIO = liftLogIO Debug+liftInfoIO = liftLogIO Info+liftWarnIO = liftLogIO Warning+liftErrorIO = liftLogIO Error+liftFatalIO = liftLogIO Fatal