module IHP.IDE.StatusServer (startStatusServer, stopStatusServer, clearStatusServer, continueStatusServer, consumeGhciOutput) where
import IHP.ViewPrelude hiding (catch)
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.WebSockets as Websocket
import qualified Network.Wai.Handler.WebSockets as Websocket
import qualified Control.Concurrent as Concurrent
import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze
import qualified Network.HTTP.Types.Header as HTTP
import qualified Text.Blaze.Html5 as Html5
import qualified Network.HTTP.Types as HTTP
import qualified Data.ByteString.Char8 as ByteString
import IHP.IDE.Types
import IHP.IDE.PortConfig
import IHP.IDE.ToolServer.Types
import IHP.IDE.ToolServer.Routes ()
import qualified Network.URI as URI
import qualified Control.Exception as Exception
import qualified Control.Concurrent.Chan.Unagi as Queue
startStatusServer :: (?context :: Context) => IO ()
startStatusServer :: (?context::Context) => IO ()
startStatusServer = do
IORef [ByteString]
standardOutput <- [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
newIORef []
IORef [ByteString]
errorOutput <- [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
newIORef []
IORef [(Connection, MVar ())]
clients <- [(Connection, MVar ())] -> IO (IORef [(Connection, MVar ())])
forall a. a -> IO (IORef a)
newIORef []
IORef (Async ())
serverRef <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) IO (Async ())
-> (Async () -> IO (IORef (Async ()))) -> IO (IORef (Async ()))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Async () -> IO (IORef (Async ()))
forall a. a -> IO (IORef a)
newIORef
(?context::Context) => StatusServerState -> IO ()
StatusServerState -> IO ()
continueStatusServer StatusServerPaused { IORef [(Connection, MVar ())]
IORef [ByteString]
IORef (Async ())
standardOutput :: IORef [ByteString]
errorOutput :: IORef [ByteString]
clients :: IORef [(Connection, MVar ())]
serverRef :: IORef (Async ())
$sel:serverRef:StatusServerNotStarted :: IORef (Async ())
$sel:clients:StatusServerNotStarted :: IORef [(Connection, MVar ())]
$sel:standardOutput:StatusServerNotStarted :: IORef [ByteString]
$sel:errorOutput:StatusServerNotStarted :: IORef [ByteString]
.. }
let serverStarted :: StatusServerState
serverStarted = StatusServerStarted { IORef (Async ())
serverRef :: IORef (Async ())
$sel:serverRef:StatusServerNotStarted :: IORef (Async ())
serverRef, IORef [(Connection, MVar ())]
clients :: IORef [(Connection, MVar ())]
$sel:clients:StatusServerNotStarted :: IORef [(Connection, MVar ())]
clients, IORef [ByteString]
standardOutput :: IORef [ByteString]
$sel:standardOutput:StatusServerNotStarted :: IORef [ByteString]
standardOutput, IORef [ByteString]
errorOutput :: IORef [ByteString]
$sel:errorOutput:StatusServerNotStarted :: IORef [ByteString]
errorOutput }
(?context::Context) => Action -> IO ()
Action -> IO ()
dispatch (StatusServerState -> Action
UpdateStatusServerState StatusServerState
serverStarted)
continueStatusServer :: (?context :: Context) => StatusServerState -> IO ()
continueStatusServer :: (?context::Context) => StatusServerState -> IO ()
continueStatusServer statusServerState :: StatusServerState
statusServerState@(StatusServerPaused { IORef [(Connection, MVar ())]
IORef [ByteString]
IORef (Async ())
$sel:serverRef:StatusServerNotStarted :: StatusServerState -> IORef (Async ())
$sel:clients:StatusServerNotStarted :: StatusServerState -> IORef [(Connection, MVar ())]
$sel:standardOutput:StatusServerNotStarted :: StatusServerState -> IORef [ByteString]
$sel:errorOutput:StatusServerNotStarted :: StatusServerState -> IORef [ByteString]
serverRef :: IORef (Async ())
clients :: IORef [(Connection, MVar ())]
standardOutput :: IORef [ByteString]
errorOutput :: IORef [ByteString]
.. }) = do
let warpApp :: Application
warpApp = ConnectionOptions -> ServerApp -> Application -> Application
Websocket.websocketsOr
ConnectionOptions
Websocket.defaultConnectionOptions
((?context::Context) =>
IORef [(Connection, MVar ())] -> StatusServerState -> ServerApp
IORef [(Connection, MVar ())] -> StatusServerState -> ServerApp
app IORef [(Connection, MVar ())]
clients StatusServerState
statusServerState)
((IORef [ByteString], IORef [ByteString]) -> Application
statusServerApp (IORef [ByteString]
standardOutput, IORef [ByteString]
errorOutput))
let port :: Port
port = ?context::Context
Context
?context.portConfig.appPort PortNumber -> (PortNumber -> Port) -> Port
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> PortNumber -> Port
forall a b. (Integral a, Num b) => a -> b
fromIntegral
Async ()
server <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Port -> Application -> IO ()
Warp.run Port
port Application
warpApp
IORef (Async ()) -> Async () -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Async ())
serverRef Async ()
server
where
statusServerApp :: (IORef [ByteString], IORef [ByteString]) -> Wai.Application
statusServerApp :: (IORef [ByteString], IORef [ByteString]) -> Application
statusServerApp (IORef [ByteString]
standardOutput, IORef [ByteString]
errorOutput) Request
req Response -> IO ResponseReceived
respond = do
Bool
isCompiling <- IO Bool
(?context::Context) => IO Bool
getCompilingStatus
[ByteString]
currentStandardOutput <- IORef [ByteString] -> IO [ByteString]
forall a. IORef a -> IO a
readIORef IORef [ByteString]
standardOutput
[ByteString]
currentErrorOutput <- IORef [ByteString] -> IO [ByteString]
forall a. IORef a -> IO a
readIORef IORef [ByteString]
errorOutput
let responseBody :: Builder
responseBody = Html -> Builder
Blaze.renderHtmlBuilder ((?context::Context) => [ByteString] -> [ByteString] -> Bool -> Html
[ByteString] -> [ByteString] -> Bool -> Html
renderErrorView [ByteString]
currentStandardOutput [ByteString]
currentErrorOutput Bool
isCompiling)
let responseHeaders :: [(HeaderName, ByteString)]
responseHeaders = [(HeaderName
HTTP.hContentType, ByteString
"text/html")]
Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, ByteString)] -> Builder -> Response
Wai.responseBuilder Status
HTTP.status200 [(HeaderName, ByteString)]
responseHeaders Builder
responseBody
stopStatusServer :: StatusServerState -> IO ()
stopStatusServer :: StatusServerState -> IO ()
stopStatusServer StatusServerStarted { IORef (Async ())
$sel:serverRef:StatusServerNotStarted :: StatusServerState -> IORef (Async ())
serverRef :: IORef (Async ())
serverRef } = do
IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IORef (Async ()) -> IO (Async ())
forall a. IORef a -> IO a
readIORef IORef (Async ())
serverRef IO (Async ()) -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Async () -> IO ()
forall a. Async a -> IO ()
uninterruptibleCancel
() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
stopStatusServer StatusServerState
_ = Text -> IO ()
putStrLn Text
"StatusServer: Cannot stop as not running"
clearStatusServer :: (?context :: Context) => StatusServerState -> IO ()
clearStatusServer :: (?context::Context) => StatusServerState -> IO ()
clearStatusServer StatusServerStarted { IORef [(Connection, MVar ())]
IORef [ByteString]
IORef (Async ())
$sel:serverRef:StatusServerNotStarted :: StatusServerState -> IORef (Async ())
$sel:clients:StatusServerNotStarted :: StatusServerState -> IORef [(Connection, MVar ())]
$sel:standardOutput:StatusServerNotStarted :: StatusServerState -> IORef [ByteString]
$sel:errorOutput:StatusServerNotStarted :: StatusServerState -> IORef [ByteString]
serverRef :: IORef (Async ())
clients :: IORef [(Connection, MVar ())]
standardOutput :: IORef [ByteString]
errorOutput :: IORef [ByteString]
.. } = do
IORef [ByteString] -> [ByteString] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [ByteString]
standardOutput []
IORef [ByteString] -> [ByteString] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [ByteString]
errorOutput []
IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IORef [(Connection, MVar ())] -> IO ()
notifyOutput IORef [(Connection, MVar ())]
clients)
() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
clearStatusServer StatusServerPaused { IORef [(Connection, MVar ())]
IORef [ByteString]
IORef (Async ())
$sel:serverRef:StatusServerNotStarted :: StatusServerState -> IORef (Async ())
$sel:clients:StatusServerNotStarted :: StatusServerState -> IORef [(Connection, MVar ())]
$sel:standardOutput:StatusServerNotStarted :: StatusServerState -> IORef [ByteString]
$sel:errorOutput:StatusServerNotStarted :: StatusServerState -> IORef [ByteString]
serverRef :: IORef (Async ())
clients :: IORef [(Connection, MVar ())]
standardOutput :: IORef [ByteString]
errorOutput :: IORef [ByteString]
.. } = do
IORef [ByteString] -> [ByteString] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [ByteString]
standardOutput []
IORef [ByteString] -> [ByteString] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [ByteString]
errorOutput []
clearStatusServer StatusServerState
StatusServerNotStarted = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
consumeGhciOutput :: (?context :: Context) => IO ()
consumeGhciOutput :: (?context::Context) => IO ()
consumeGhciOutput = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever do
OutputLine
line <- OutChan OutputLine -> IO OutputLine
forall a. OutChan a -> IO a
Queue.readChan ?context::Context
Context
?context.ghciOutChan
AppState
appState <- IORef AppState -> IO AppState
forall a. IORef a -> IO a
readIORef ?context::Context
Context
?context.appStateRef
let shouldIgnoreLine :: Bool
shouldIgnoreLine = (OutputLine
line OutputLine -> OutputLine -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> OutputLine
ErrorOutput ByteString
"Warning: -debug, -threaded and -ticky are ignored by GHCi")
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
shouldIgnoreLine do
let writeOutputLine :: IORef [ByteString] -> IORef [ByteString] -> IO ()
writeOutputLine IORef [ByteString]
standardOutput IORef [ByteString]
errorOutput = do
case OutputLine
line of
StandardOutput ByteString
line -> IORef [ByteString] -> ([ByteString] -> [ByteString]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [ByteString]
standardOutput (ByteString
line:)
ErrorOutput ByteString
line -> IORef [ByteString] -> ([ByteString] -> [ByteString]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [ByteString]
errorOutput (ByteString
line:)
case AppState
appState.statusServerState of
StatusServerStarted { IORef [(Connection, MVar ())]
$sel:clients:StatusServerNotStarted :: StatusServerState -> IORef [(Connection, MVar ())]
clients :: IORef [(Connection, MVar ())]
clients, IORef [ByteString]
$sel:standardOutput:StatusServerNotStarted :: StatusServerState -> IORef [ByteString]
standardOutput :: IORef [ByteString]
standardOutput, IORef [ByteString]
$sel:errorOutput:StatusServerNotStarted :: StatusServerState -> IORef [ByteString]
errorOutput :: IORef [ByteString]
errorOutput } -> do
IORef [ByteString] -> IORef [ByteString] -> IO ()
writeOutputLine IORef [ByteString]
standardOutput IORef [ByteString]
errorOutput
IORef [(Connection, MVar ())] -> IO ()
notifyOutput IORef [(Connection, MVar ())]
clients
StatusServerPaused { IORef [ByteString]
$sel:standardOutput:StatusServerNotStarted :: StatusServerState -> IORef [ByteString]
standardOutput :: IORef [ByteString]
standardOutput, IORef [ByteString]
$sel:errorOutput:StatusServerNotStarted :: StatusServerState -> IORef [ByteString]
errorOutput :: IORef [ByteString]
errorOutput } -> do
IORef [ByteString] -> IORef [ByteString] -> IO ()
writeOutputLine IORef [ByteString]
standardOutput IORef [ByteString]
errorOutput
StatusServerState
otherwise -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
notifyOutput :: IORef [(Websocket.Connection, Concurrent.MVar ())] -> IO ()
notifyOutput :: IORef [(Connection, MVar ())] -> IO ()
notifyOutput IORef [(Connection, MVar ())]
stateRef = do
[(Connection, MVar ())]
clients <- IORef [(Connection, MVar ())] -> IO [(Connection, MVar ())]
forall a. IORef a -> IO a
readIORef IORef [(Connection, MVar ())]
stateRef
[(Connection, MVar ())]
-> ((Connection, MVar ()) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Connection, MVar ())]
clients \(Connection
connection, MVar ()
didChangeMVar) -> do
Bool
_ <- MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
Concurrent.tryPutMVar MVar ()
didChangeMVar ()
() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
data CompilerError = CompilerError { CompilerError -> [ByteString]
errorMessage :: [ByteString], CompilerError -> Bool
isWarning :: Bool } deriving (Port -> CompilerError -> ShowS
[CompilerError] -> ShowS
CompilerError -> String
(Port -> CompilerError -> ShowS)
-> (CompilerError -> String)
-> ([CompilerError] -> ShowS)
-> Show CompilerError
forall a.
(Port -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Port -> CompilerError -> ShowS
showsPrec :: Port -> CompilerError -> ShowS
$cshow :: CompilerError -> String
show :: CompilerError -> String
$cshowList :: [CompilerError] -> ShowS
showList :: [CompilerError] -> ShowS
Show)
renderErrorView :: (?context :: Context) => [ByteString] -> [ByteString] -> Bool -> Html5.Html
renderErrorView :: (?context::Context) => [ByteString] -> [ByteString] -> Bool -> Html
renderErrorView [ByteString]
standardOutput [ByteString]
errorOutput Bool
isCompiling = [hsx|
<html lang="en">
<head>
<meta charset="utf-8"/>
{title}
<style>
* { -webkit-font-smoothing: antialiased }
body {
font-size: 16px;
font-family: -apple-system, Roboto, "Helvetica Neue", Arial, sans-serif;
background-color: hsl(196 13% 30% / 1);
color: hsla(196, 13%, 96%, 1);
}
.compiler-error .file-name {
margin-bottom: 1rem;
font-weight: bold;
display: block;
color: inherit !important;
text-decoration: none;
}
.compiler-error {
margin-bottom: 3rem;
font-size: 0.7rem;
}
.ihp-error-other-solutions {
margin-top: 2rem;
padding-top: 0.5rem;
font-size: 0.8rem;
color: hsla(196, 13%, 80%, 1);
border-top: 1px solid hsla(196, 13%, 60%, 0.4);
margin-bottom: 4rem;
}
.ihp-error-other-solutions a {
color: hsla(196, 13%, 80%, 0.9);
text-decoration: none !important;
margin-right: 2rem;
font-size: 0.8rem;
}
.ihp-error-other-solutions a:hover {
color: hsla(196, 13%, 80%, 1);
}
.troubleshooting-suggestion {
margin-top: 1rem;
}
.troubleshooting-suggestion, .troubleshooting-suggestion a {
font-weight: bold;
color: #859900 !important;
}
#stderr .compiler-error:first-child { opacity: 1; font-size: 1rem; }
#stderr .compiler-error:first-child .file-name { font-size: 1.5rem; }
#stderr .compiler-error { opacity: 0.5; }
#ihp-error-container {
max-width: 800px;
margin-left: auto;
margin-right: auto;
}
</style>
</head>
<body>
{errorContainer}
<script>
var socket = new WebSocket("ws://localhost:" + window.location.port);
var parser = new DOMParser();
socket.onclose = function () { setTimeout(() => window.location.reload(), 500); }
socket.onmessage = function (event) {
if (event.data !== 'pong') {
var responseBody = parser.parseFromString(event.data, 'text/html');
document.getElementById('ihp-error-container').outerHTML = responseBody.getElementById('ihp-error-container').outerHTML;
}
}
</script>
</body>
</html>
|]
where
errorContainer :: Html
errorContainer = [hsx|
<div id="ihp-error-container">
<h1 style="margin-bottom: 2rem; margin-top: 20%; font-size: 1rem; font-weight: 400; border-bottom: 1px solid white; padding-bottom: 0.25rem; border-color: hsla(196, 13%, 60%, 1); color: hsla(196, 13%, 80%, 1)">{inner}</h1>
<pre style="font-family: Menlo, monospace; width: 100%" id="stderr">{forEach errors renderError}</pre>
<div class="ihp-error-other-solutions">
<a href="https://ihp.digitallyinduced.com/Slack" target="_blank">Ask on Slack</a>
<a href="https://stackoverflow.com/questions/tagged/ihp" target="_blank">Ask on Stack Overflow</a>
<a href="https://github.com/digitallyinduced/ihp/wiki/Troubleshooting" target="_blank">Check the Troubleshooting</a>
<a href={("https://github.com/digitallyinduced/ihp/issues/new?body=" :: Text) <> cs (URI.escapeURIString URI.isUnescapedInURI (cs $ ByteString.unlines errorOutput))} target="_blank">Open a GitHub Issue</a>
</div>
<pre style="font-family: Menlo, monospace; font-size: 10px" id="stdout">{ByteString.unlines (reverse standardOutput)}</pre>
</div>
|]
where
errors :: [CompilerError]
errors = [ByteString]
errorOutput
[ByteString]
-> ([ByteString] -> [CompilerError]) -> [CompilerError]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [ByteString] -> [CompilerError]
parseErrorOutput
[CompilerError]
-> ([CompilerError] -> [CompilerError]) -> [CompilerError]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (CompilerError -> CompilerError -> Ordering)
-> [CompilerError] -> [CompilerError]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((CompilerError -> Bool)
-> CompilerError -> CompilerError -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (.isWarning))
parseErrorOutput :: [ByteString] -> [CompilerError]
parseErrorOutput :: [ByteString] -> [CompilerError]
parseErrorOutput [ByteString]
output =
[ByteString] -> [[ByteString]] -> [[ByteString]]
splitToSections ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
output) []
[[ByteString]]
-> ([[ByteString]] -> [CompilerError]) -> [CompilerError]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ([ByteString] -> CompilerError)
-> [[ByteString]] -> [CompilerError]
forall a b. (a -> b) -> [a] -> [b]
map [ByteString] -> CompilerError
identifySection
where
splitToSections :: [ByteString] -> [[ByteString]] -> [[ByteString]]
splitToSections :: [ByteString] -> [[ByteString]] -> [[ByteString]]
splitToSections [] [[ByteString]]
result = [[ByteString]]
result
splitToSections (ByteString
"":[ByteString]
lines) [[ByteString]]
result = [ByteString] -> [[ByteString]] -> [[ByteString]]
splitToSections [ByteString]
lines [[ByteString]]
result
splitToSections [ByteString]
lines [[ByteString]]
result =
let ([ByteString]
error :: [ByteString], [ByteString]
rest) = (ByteString -> Bool)
-> [ByteString] -> ([ByteString], [ByteString])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\ByteString
line -> ByteString
line ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") [ByteString]
lines
in [ByteString] -> [[ByteString]] -> [[ByteString]]
splitToSections [ByteString]
rest (([ByteString]
error [ByteString] -> ([ByteString] -> [ByteString]) -> [ByteString]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
""))[ByteString] -> [[ByteString]] -> [[ByteString]]
forall a. a -> [a] -> [a]
:[[ByteString]]
result)
identifySection :: [ByteString] -> CompilerError
identifySection :: [ByteString] -> CompilerError
identifySection [ByteString]
lines | ByteString
"warning" ByteString -> ByteString -> Bool
`ByteString.isInfixOf` (ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" ([ByteString] -> Maybe ByteString
forall a. [a] -> Maybe a
headMay [ByteString]
lines)) = CompilerError { $sel:errorMessage:CompilerError :: [ByteString]
errorMessage = [ByteString]
lines, $sel:isWarning:CompilerError :: Bool
isWarning = Bool
True }
identifySection [ByteString]
lines = CompilerError { $sel:errorMessage:CompilerError :: [ByteString]
errorMessage = [ByteString]
lines, $sel:isWarning:CompilerError :: Bool
isWarning = Bool
False }
title :: Html
title = if Bool
isCompiling
then [hsx|<title>Compiling...</title>|]
else [hsx|<title>Compilation Error</title>|]
inner :: Html
inner = if Bool
isCompiling
then [hsx|Is compiling|]
else [hsx|Problems found while compiling|]
renderError :: CompilerError -> Html
renderError CompilerError { [ByteString]
$sel:errorMessage:CompilerError :: CompilerError -> [ByteString]
errorMessage :: [ByteString]
errorMessage, Bool
$sel:isWarning:CompilerError :: CompilerError -> Bool
isWarning :: Bool
isWarning } = [hsx|
<div class="compiler-error">
{forEachWithIndex errorMessage renderLine}
{mconcat (renderTroubleshooting errorMessage)}
</div>
|]
renderLine :: (Port, ByteString) -> Html
renderLine (Port
0, ByteString
line) = [hsx|
<a class="file-name" href={openEditor} target={line}>{filePath}</a>
<iframe name={line} src="about:blank" style="display: none"/>
|]
where
(ByteString
filePath, ByteString
rest) = ByteString -> ByteString -> (ByteString, ByteString)
ByteString.breakSubstring ByteString
": " ByteString
line
openEditor :: Text
openEditor = Text
"http://localhost:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PortNumber -> Text
forall a. Show a => a -> Text
tshow PortNumber
toolServerPort Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (LogsController -> Text
forall controller. HasPath controller => controller -> Text
pathTo LogsController
OpenEditorAction) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"?path=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
plainFilePath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"&line=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
fileLine Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"&col=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
fileCol
(ByteString
plainFilePath, ByteString
fileLine, ByteString
fileCol) = case Char -> ByteString -> [ByteString]
ByteString.split Char
':' ByteString
filePath of
[ByteString
path, ByteString
line, ByteString
col, ByteString
rest] -> (ByteString
path, ByteString
line, ByteString
col)
[ByteString
path, ByteString
line, ByteString
col] -> (ByteString
path, ByteString
line, ByteString
col)
[ByteString
path, ByteString
line] -> (ByteString
path, ByteString
line, ByteString
"0")
[ByteString]
otherwise -> (ByteString
filePath, ByteString
"0", ByteString
"0")
renderLine (Port
i, ByteString
line) = [hsx|<div>{line}</div>|]
renderTroubleshooting :: [ByteString] -> [Html5.Html]
renderTroubleshooting :: [ByteString] -> [Html]
renderTroubleshooting [ByteString]
lines = [ [ByteString] -> Maybe Html
modelContextTroubleshooting ]
[[ByteString] -> Maybe Html]
-> ([[ByteString] -> Maybe Html] -> [Maybe Html]) -> [Maybe Html]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (([ByteString] -> Maybe Html) -> Maybe Html)
-> [[ByteString] -> Maybe Html] -> [Maybe Html]
forall a b. (a -> b) -> [a] -> [b]
map (\[ByteString] -> Maybe Html
f -> [ByteString] -> Maybe Html
f [ByteString]
lines)
[Maybe Html] -> ([Maybe Html] -> [Html]) -> [Html]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Maybe Html] -> [Html]
forall a. [Maybe a] -> [a]
catMaybes
toolServerPort :: PortNumber
toolServerPort = ?context::Context
Context
?context.portConfig.toolServerPort
app :: (?context :: Context) => IORef [(Websocket.Connection, Concurrent.MVar ())] -> StatusServerState -> Websocket.ServerApp
app :: (?context::Context) =>
IORef [(Connection, MVar ())] -> StatusServerState -> ServerApp
app IORef [(Connection, MVar ())]
stateRef StatusServerState
statusServerState PendingConnection
pendingConnection = do
Connection
connection <- PendingConnection -> IO Connection
Websocket.acceptRequest PendingConnection
pendingConnection
MVar ()
didChangeMVar <- IO (MVar ())
forall a. IO (MVar a)
Concurrent.newEmptyMVar
IORef [(Connection, MVar ())]
-> ([(Connection, MVar ())] -> [(Connection, MVar ())]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [(Connection, MVar ())]
stateRef (([(Connection, MVar ())] -> [(Connection, MVar ())]) -> IO ())
-> ([(Connection, MVar ())] -> [(Connection, MVar ())]) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[(Connection, MVar ())]
state -> ((Connection
connection, MVar ()
didChangeMVar) (Connection, MVar ())
-> [(Connection, MVar ())] -> [(Connection, MVar ())]
forall a. a -> [a] -> [a]
: [(Connection, MVar ())]
state)
let notifyClient :: IO ()
notifyClient = do
MVar () -> IO ()
forall a. MVar a -> IO a
Concurrent.takeMVar MVar ()
didChangeMVar
Port -> IO ()
Concurrent.threadDelay Port
100000
Bool
isCompiling <- IO Bool
(?context::Context) => IO Bool
getCompilingStatus
[ByteString]
standardOutput' <- IORef [ByteString] -> IO [ByteString]
forall a. IORef a -> IO a
readIORef (StatusServerState
statusServerState.standardOutput)
[ByteString]
errorOutput' <- IORef [ByteString] -> IO [ByteString]
forall a. IORef a -> IO a
readIORef (StatusServerState
statusServerState.errorOutput)
let errorContainer :: Html
errorContainer = (?context::Context) => [ByteString] -> [ByteString] -> Bool -> Html
[ByteString] -> [ByteString] -> Bool -> Html
renderErrorView [ByteString]
standardOutput' [ByteString]
errorOutput' Bool
isCompiling
let html :: ByteString
html = Html -> ByteString
Blaze.renderHtml Html
errorContainer
Either SomeException ()
result <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (Connection -> ByteString -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
Websocket.sendTextData Connection
connection ByteString
html)
case Either SomeException ()
result of
Left (Exception.SomeException e
e) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Right ()
_ -> IO ()
notifyClient
IO ()
notifyClient
() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
modelContextTroubleshooting :: [ByteString] -> Maybe Html5.Html
modelContextTroubleshooting :: [ByteString] -> Maybe Html
modelContextTroubleshooting [ByteString]
lines =
[ByteString]
lines
[ByteString] -> ([ByteString] -> [Bool]) -> [Bool]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (ByteString -> Bool) -> [ByteString] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
line -> ByteString
"Unbound implicit parameter (?modelContext::" ByteString -> ByteString -> Bool
`ByteString.isInfixOf` ByteString
line)
[Bool] -> ([Bool] -> Bool) -> Bool
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
Bool -> (Bool -> Maybe Html) -> Maybe Html
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> \case
Bool
True -> Html -> Maybe Html
forall a. a -> Maybe a
Just [hsx|
<div class="troubleshooting-suggestion">
A detailed explanation for this error is available in the IHP Wiki:
<a href="https://github.com/digitallyinduced/ihp/wiki/Troubleshooting#unbound-implicit-parameter-modelcontextmodelcontext" target="_blank">See Error Explanation</a>
</div>
|]
Bool
False -> Maybe Html
forall a. Maybe a
Nothing
getCompilingStatus :: (?context :: Context) => IO Bool
getCompilingStatus :: (?context::Context) => IO Bool
getCompilingStatus = do
AppState
devServerState <- IORef AppState -> IO AppState
forall a. IORef a -> IO a
readIORef ?context::Context
Context
?context.appStateRef
Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure case (AppState
devServerState.appGHCIState) of
AppGHCILoading { } -> Bool
True
AppGHCIState
_ -> Bool
False