{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} module Main where import Control.Monad.Trans import qualified Data.ByteString as BS import Data.FileEmbed import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Monoid import qualified Data.Text.Lazy as T import Language.Haskell.Interpreter hiding (get) import Network.Wai.Handler.Warp (Settings(..), defaultSettings, runSettings) import System.Directory (createDirectoryIfMissing, getTemporaryDirectory) import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes (class_, href, rel, src, type_) import Yesod import Yesod.Static import Control.Applicative import Control.Concurrent import Control.Concurrent.MVar import Control.Monad (forM_, forever, liftM, mzero, void) import Control.Monad.Error.Class import Data.Aeson ((.:), (.=)) import Data.Char (isUpper) import qualified Data.Text as ST import qualified Data.Text.Lazy.Encoding as LTE import Data.Typeable import Network.Web.GHCLive.Display import Text.Blaze import Text.Blaze.Internal (preEscapedText, text) import Text.Blaze.Renderer.Text (renderMarkup) import qualified Data.Aeson as J import qualified Data.Aeson.Types as J import qualified Data.HashMap.Strict as HM import Data.Map (Map) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text.IO as DTI import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import qualified Data.Vector as V import Network.Wai import qualified Network.Wai.Handler.WebSockets as WS import qualified Network.WebSockets as WS import Prelude import qualified SeqMap as SM import SignalHandlers type Hint = Run (InterpreterT IO) data Run m = Run { vRequest :: MVar (m ()) } -- hint gives Either InterpreterError DisplayResult jsonerror expr err = object ["expr" .= expr, "error" .= err] jsonresult expr res = object ["expr" .= expr, "result" .= res] data GHCLive = GHCLive { ref :: MVar [J.Value] -- list of jsonerror or jsonresult Values , hint :: Hint , editor :: Editor , getStatic :: Static , tmpdir :: FilePath } data Editor = Editor { doc :: MVar (Document, Map ClientId Client) , unique :: MVar ClientId } data Operation = InsertAfter AtomId AtomId Char | Remove AtomId deriving (Show, Eq, Ord) data OpBlock = OpBlock [Operation] deriving (Show, Eq, Ord) -- inefficiently, [(AtomId,TextAtom)] type Document = SM.SeqMap AtomId TextAtom -- Char, and whether this Char has been removed data TextAtom = TextAtom { taCh :: Char , taRemoved :: Maybe Timestamp } deriving Show doc2string seqmap = map taCh $ filter (isNothing . taRemoved) (map snd (SM.toList seqmap)) emptyDoc = SM.singleton (AtomId (Timestamp 0) (ClientId 0)) (TextAtom ' ' (Just (Timestamp 0))) newtype Timestamp = Timestamp { unTimestamp :: Integer } deriving (Eq, Ord, Show, J.ToJSON, J.FromJSON) newtype ClientId = ClientId { unClientId :: Integer } deriving (Eq, Ord, Show, Enum, J.ToJSON, J.FromJSON) data Client = Client { clientConnected :: Timestamp -- timestamp when client connected , clientId :: ClientId -- unique id , clientChan :: Chan J.Value -- post outgoing messages to this chan } mkTa :: Char -> TextAtom mkTa ch = TextAtom ch Nothing -- a Client never makes two IDs with the same timestamp data AtomId = AtomId { aiTime :: Timestamp , aiClient :: ClientId } deriving (Show, Ord, Eq) instance J.ToJSON AtomId where toJSON (AtomId (Timestamp t) (ClientId c)) = J.toJSON [t,c] -- atoms encoded in json as [time,clientid] instance J.FromJSON AtomId where parseJSON (J.Array v) | V.length v == 2 = AtomId <$> J.parseJSON (v V.! 0) <*> J.parseJSON (v V.! 1) parseJSON _ = mzero staticDir = "static" staticSiteFiles :: Static staticSiteFiles = $(embed "static") staticSite :: IO Static staticSite = do #ifdef DEVELOPMENT putStrLn ("using web files from: " ++ staticDir ++ "/") Static.staticDevel staticDir #else putStrLn "using embedded web files" return $(embed "static") #endif -- switch to this when working on the javascript to prevent recompiling each time -- staticSite :: IO Static -- staticSite = staticDevel "static" $(staticFiles "static") mkYesod "GHCLive" [parseRoutes| / RootR GET /eval EvalR GET /static StaticR Static getStatic /loader LoaderR GET /edit EditR GET /results ResultsR GET |] instance Yesod GHCLive where makeSessionBackend _ = return Nothing main :: IO () main = do -- filesystem setup tmp <- getTemporaryDirectory let cachedir = (tmp ++ "/ghclive/") createDirectoryIfMissing False cachedir BS.writeFile (cachedir ++ "Helper.hs") helperFile -- hint setup r <- newMVar ([] :: [J.Value]) h <- newHint ss <- staticSite -- shared editor setup d <- newMVar (emptyDoc, M.empty) u <- newMVar (ClientId 0) let editor = Editor d u let master = GHCLive r h editor ss cachedir s = defaultSettings { settingsPort = 3000 , settingsIntercept = WS.intercept (sockets editor) } putStrLn $ "To use ghcLiVE, point your web browser to http://localhost:" ++ show (settingsPort s) runSettings s =<< (toWaiApp master :: IO Yesod.Application) getLoaderR = do y <- getYesod cs <- liftIO $ readMVar (doc $ editor y) t <- liftIO . performHint (hint y) $ moduleHint (doc2string $ fst cs) (tmpdir y) case t of Left error -> jsonToRepJson $ cleanShow error Right displayres -> jsonToRepJson displayres getRootR :: Handler RepHtml getRootR = redirect EditR getResultsR = do y <- getYesod h <- liftIO $ readMVar (ref y) jsonToRepJson h -- send ALL the state! getEvalR :: Handler RepJson getEvalR = do y <- getYesod expr <- fromMaybe "" <$> lookupGetParam "expr" liftIO $ putStr "expression is " liftIO $ DTI.putStrLn expr -- get Editor with getYesod and then document -- get the clients from the editor document (see applyOps for an example) (_, clients) <- liftIO $ readMVar (doc $ editor y) -- - call pushToClients with the clients and the JSON message you want to send, for example: object [ "refresh" .= True ] (t :: Either InterpreterError DisplayResult) <- liftIO . performHint (hint y) $ interpretHint ("displaying " ++ parens (ST.unpack expr)) pushToClients clients $ object [ "refreshoutput" .= True ] case t of Left error -> do let jserr = jsonerror expr (cleanShow error) liftIO $ modifyMVar_ (ref y) $ \x -> return (x ++ [jserr]) jsonToRepJson jserr Right displayres -> do let jsres = jsonresult expr displayres liftIO $ modifyMVar_ (ref y) $ \x -> return (x ++ [jsres]) jsonToRepJson jsres interpretHint :: (Typeable a, MonadInterpreter m) => String -> m a interpretHint expr = set [ languageExtensions := (NoMonomorphismRestriction:ExtendedDefaultRules:glasgowExtensions) ] >> interpret expr as moduleHint :: MonadInterpreter m => String -> FilePath -> m [ModuleName] moduleHint ms cachedir = do -- save the file liftIO . putStrLn $ "calling cachedir with " ++ cachedir ++ " and " ++ (take 50 ms) liftIO $ cacheFile cachedir ms let allfiles = ["Helper.hs", "Main.hs"] reset liftIO $ putStrLn $ "will be loading " ++ (show $ map (cachedir ++) allfiles) loadModules $ map (cachedir ++) allfiles ms <- getLoadedModules setTopLevelModules ms setImports $ ["Prelude", "Network.Web.GHCLive.Display", "Text.Blaze"] ++ ms return ms -- eval :: String -> Interpret String -- eval "something" ~= interpret "(show something) (as :: String)" {----------------------------------------------------------------------------- Interpreter abstraction ------------------------------------------------------------------------------} newHint :: IO Hint newHint = newRun $ \a -> void $ runInterpreter (liftIO restoreHandlers >> a) performHint :: Hint -> InterpreterT IO a -> IO (Either InterpreterError a) performHint hint act = perform hint $ (Right `liftM` act) `catchError` (return . Left) {- loadFile :: Hint -> FilePath -> IO () loadFile w filepath = perform w $ do evaluate :: Hint -> String -> IO String evaluate w expr = perform w $ do -- stopInterpreter :: Hint -> IO () -} -- | Thread responsible for "running" a monad that can do IO. perform :: MonadIO m => Run m -> m a -> IO a perform run act = do ref <- newEmptyMVar putMVar (vRequest run) $ do a <- act liftIO $ putMVar ref a takeMVar ref newRun :: MonadIO m => (m () -> IO ()) -> IO (Run m) newRun f = do vRequest <- newEmptyMVar forkIO . f . forever $ do act <- liftIO $ takeMVar vRequest act return Run { vRequest = vRequest } cleanShow :: InterpreterError -> String cleanShow ie = case ie of UnknownError e -> "UnknownError\n" ++ e WontCompile es -> unlines $ map errMsg es NotAllowed e -> "NotAllowed\n" ++ e GhcException e -> "GhcException\n" ++ e cacheFile cachedir f = do putStrLn $ "cachedir is " ++ cachedir putStrLn $ "text is " ++ (take 50 f) writeFile (cachedir ++ "Main.hs") f return "Main.hs" liveLayout :: Widget -> Handler RepHtml liveLayout w = do p <- widgetToPageContent w hamletToRepHtml [hamlet|$newline never $doctype 5