hpage 0.6.2 → 0.7.0
raw patch · 4 files changed
+74/−16 lines, 4 files
Files
- hpage.cabal +2/−2
- src/HPage/Control.hs +44/−9
- src/HPage/IOServer.hs +23/−0
- src/HPage/Utils/Log.hs +5/−5
hpage.cabal view
@@ -1,5 +1,5 @@ name: hpage-version: 0.6.2+version: 0.7.0 cabal-version: >=1.6 build-type: Custom license: BSD3@@ -50,5 +50,5 @@ 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+ other-modules: HPage.GUI.IDs, HPage.GUI.FreeTextWindow, HPage.GUI.Dialogs, HPage.Control, HPage.Server, HPage.Utils.Log, HPage.GUI.Constants, HPage.IOServer ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns
src/HPage/Control.hs view
@@ -77,6 +77,7 @@ 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}@@ -159,7 +160,9 @@ ghcOptions :: String, server :: HS.ServerHandle, running :: Maybe InFlightData,- recoveryLog :: Hint.InterpreterT IO () -- To allow cancelation of actions+ recoveryLog :: Hint.InterpreterT IO (), -- To allow cancelation of actions+ -- IO Server --+ ioServer :: HPIO.ServerHandle } instance Show Context where@@ -189,8 +192,9 @@ 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+ let emptyContext = Context Nothing [] [emptyPage] 0 empty (fromList ["Prelude"]) [] "" hs Nothing nop hpios (state hpt) `evalStateT` emptyContext @@ -451,7 +455,23 @@ in "No instance for (GHC.Show" `isPrefixOf` errMsg valueOfNth, kindOfNth, typeOfNth :: Int -> HPage (Either Hint.InterpreterError String)-valueOfNth = runInExprNthWithLets Hint.eval+valueOfNth i =+ do+ res <- runInExprNthWithLets Hint.typeOf i+ case res of+ Right ('I':'O':' ':_:_) -> -- An IO Action+ do+ res2 <- getIOFromExprNth i+ case res2 of+ Right ioAction ->+ do+ ctx <- get+ iores <- liftIO $ HPIO.runIn (ioServer ctx) ioAction+ return $ Right iores+ Left err ->+ return $ Left err+ _ ->+ runInExprNthWithLets Hint.eval i kindOfNth = runInExprNth Hint.kindOf typeOfNth = runInExprNthWithLets Hint.typeOf @@ -711,10 +731,13 @@ 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,- running = Nothing})+ 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)@@ -763,6 +786,16 @@ 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)+ runInExprNthWithLets :: (String -> Hint.InterpreterT IO String) -> Int -> HPage (Either Hint.InterpreterError String) runInExprNthWithLets action i = do page <- getPage@@ -770,9 +803,11 @@ 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+ in do+ liftDebugIO expr+ syncRun $ if "" == exprText item+ then return ""+ else action expr syncRun :: Hint.InterpreterT IO a -> HPage (Either Hint.InterpreterError a) syncRun action = do@@ -866,7 +901,7 @@ letsToString :: [Expression] -> String letsToString [] = ""-letsToString exs = "let " ++ joinWith "; " (map exprText exs) ++ " in "+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
+ src/HPage/IOServer.hs view
@@ -0,0 +1,23 @@++module HPage.IOServer (+ start, stop, runIn, ServerHandle+ ) where++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 a+runIn server action = runHere $ do+ me <- self+ sendTo (handle server) $ action >>= sendTo me+ recv++stop :: ServerHandle -> IO ()+stop = kill . handle
src/HPage/Utils/Log.hs view
@@ -17,12 +17,12 @@ traceIO, debugIO, infoIO, warnIO, errorIO, fatalIO :: Show a => a -> IO () liftTraceIO, liftDebugIO, liftInfoIO, liftWarnIO, liftErrorIO, liftFatalIO :: (MonadIO m, Show a) => a -> m () +{- with log... traceIO = logIO Trace debugIO = logIO Debug-{- without log...+-} traceIO _ = return () debugIO _ = return ()--} infoIO = logIO Info warnIO = logIO Warning errorIO = logIO Error@@ -30,11 +30,11 @@ {- with log... liftTraceIO = liftLogIO Trace+liftDebugIO = liftLogIO Debug -} liftTraceIO _ = return () -liftDebugIO = liftLogIO Debug+liftDebugIO _ = return () liftInfoIO = liftLogIO Info liftWarnIO = liftLogIO Warning--- liftErrorIO = liftLogIO Error-liftErrorIO _ = return ()+liftErrorIO = liftLogIO Error liftFatalIO = liftLogIO Fatal