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

-- async (notifyOutput (standardOutput, errorOutput) clients)

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 are reordered here as we want to display the most important compile errors first
                    -- Warnings should come after the actual errors.
                    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) -- This happens for parser errors from the IHP.SchemaCompiler.compile function
                            [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
            -- Blocks until a change happens
            MVar () -> IO ()
forall a. MVar a -> IO a
Concurrent.takeMVar MVar ()
didChangeMVar

            -- Debounce
            Port -> IO ()
Concurrent.threadDelay Port
100000 -- 100ms

            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 () -- Client was probably disconnected
                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