ghclive (empty) → 0.1.0.0
raw patch · 5 files changed
+765/−0 lines, 5 filesdep +aesondep +basedep +blaze-htmlsetup-changed
Dependencies added: aeson, base, blaze-html, blaze-markup, bytestring, containers, diagrams-lib, diagrams-svg, directory, file-embed, ghc-prim, ghclive, hint, mtl, text, time, unix, unordered-containers, vector, wai, wai-websockets, warp, websockets, yesod, yesod-static
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- ghclive.cabal +67/−0
- src-main/Main.hs +496/−0
- src/Network/Web/GHCLive/Display.hs +170/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Shae Erisson++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 Shae Erisson 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ghclive.cabal view
@@ -0,0 +1,67 @@+name: ghclive+-- The package version. See the Haskell package versioning policy (PVP)+-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0.0+synopsis: Interactive Haskell interpreter in a browser.+Description:+ ghclive is an interactive Haskell interactive in a browser.+ It can do most of what ghci does, with a few extra abilities.++homepage: http://github.com/shapr/ghclive/+license: BSD3+license-file: LICENSE+author: Shae Erisson+maintainer: shae@ScannedInAvian.com+category: Web, Compilers/Interpreters, Application+build-type: Simple+cabal-version: >=1.8+Library+ build-depends:+ aeson > 0.6 && < 0.7,+ base >= 4 && < 5,+ blaze-html > 0.5,+ blaze-markup > 0.5,+ diagrams-lib > 0.5,+ diagrams-svg > 0.3,+ ghc-prim,+ text > 0.11,+ unix > 2,+ containers > 0.4+ hs-source-dirs: src+ exposed-modules:+ Network.Web.GHCLive.Display++executable ghclive+ main-is: Main.hs++ if !os(windows)+ build-depends: unix+ build-depends:+ ghclive > 0.0.1,+ yesod-static,+ mtl >= 2.0 && < 3,+ containers > 0.4,+ unix > 2,+ wai-websockets > 1.3,+ websockets,+ wai >= 1.3 && < 1.4,+ time > 1.3,+ vector > 0.9,+ unordered-containers > 0.2,+ blaze-markup > 0.5,+ aeson > 0.6 && < 0.7,+ text > 0.11,+ yesod >= 1.1 && < 1.2,+ warp >= 1.3 && < 1.4,+ blaze-html,+ bytestring > 0.9,+ hint == 0.3.*,+ directory,+ file-embed > 0.0.4,+ base >= 4 && < 5++ hs-source-dirs: src-main
+ src-main/Main.hs view
@@ -0,0 +1,496 @@+{-# 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+ <html>+ <head>+ <title>GHCLive+ ^{pageHead p}+ <body>+ ^{pageBody p}+ |]++helperFile :: BS.ByteString+helperFile = $(embedFile "cache/Helper.hs")++{-- shared editor --}+getEditR :: Handler RepHtml+getEditR = liveLayout $ do+ addScript (StaticR jquery_js)+ addScript (StaticR codemirror_lib_codemirror_js)+ addScript (StaticR codemirror_mode_haskell_haskell_js)+ addScript (StaticR document_js)+ addStylesheet (StaticR codemirror_lib_codemirror_css)+ addStylesheet (StaticR foo_css)+ addScript (StaticR jquery_ui_1_8_23_custom_min_js)+ addStylesheet (StaticR jquery_ui_1_8_23_custom_css)+ addScript (StaticR jquery_layout_latest_js)+ addScript (StaticR jquery_scrollTo_js)+ addScript (StaticR ghclive_js)+ toWidget [lucius|+ #editor {+ width: 800px;+ height: 500px;+ }+ |]+ [whamlet|$newline never+ <div id="editor-pane" class="ui-layout-north">+ <div class="ui-layout-content">+ <textarea #editor>+ <form action="#">+ <input type=submit value="Load shared document" #load>+ <div class="ui-layout-center">+ <div #editormessages>+ <div #output class="ui-layout-content">+ <div class="ui-layout-south">+ <form id="evalform" action="#">+ <div id="eval-panel">+ <input type=text placeholder="Enter a Haskell expression" #expr>+ <div class="ui-layout-west">+ <div class="ui-layout-east">+ |]++insertAtom :: AtomId -> AtomId -> Char -> Document -> Document+insertAtom after aid ch d = go xs+ where+ xs = drop 1 $ SM.toListFrom after d+ go [] = d SM.|> (aid, mkTa ch)+ go ((y,_):ys) | aid < y = go xs+ | otherwise = SM.insertBefore y (aid, mkTa ch) d++removeAtom :: AtomId -> Timestamp -> Document -> Document+removeAtom a time = SM.adjust (\(TextAtom ch _) -> TextAtom ch (Just time)) a++-- |'getTimestamp' returns the timestamp in milliseconds+getTimestamp :: MonadIO m => m Timestamp+getTimestamp = liftIO $ liftM (Timestamp . round . (*1000) . utcTimeToPOSIXSeconds) getCurrentTime++{-+collectGarbage :: Integer -> Document -> Document+collectGarbage time d = SM.removeAll ks d+ where+ ks = filter ((< time) . aiTime) (SM.keys d)+-}++t :: Text -> Text+t = id++mkClientId :: MonadIO m => Editor -> m ClientId+mkClientId e = liftIO (modifyMVar (unique e) $ \u -> let u' = succ u in return (u',u'))++pushToClients :: MonadIO m => Map ClientId Client -> J.Value -> m ()+pushToClients cs msg = do+ forM_ (M.elems cs) $ \c -> liftIO (writeChan (clientChan c) msg)++applyOps :: MonadIO m => Editor -> [Operation] -> m ()+applyOps e ops = do+ mapM_ (applyOp e) ops+ (_, clients) <- liftIO $ readMVar (doc e)+ pushToClients clients $ J.toJSON (OpBlock ops)++applyOp :: MonadIO m => Editor -> Operation -> m ()+applyOp e (InsertAfter a0 ai ch) = liftIO $ modifyMVar_ (doc e) $ \(d,clients) -> do+ let d' = insertAtom a0 ai ch d+ return (d',clients)+applyOp e (Remove a) = liftIO $ modifyMVar_ (doc e) $ \(d,clients) -> do+ time <- getTimestamp+ let d' = removeAtom a time d+ return (d', clients)+++instance J.FromJSON OpBlock where+ parseJSON (J.Object o) = OpBlock <$> o .: "actions"+ parseJSON _ = mzero++instance J.ToJSON OpBlock where+ toJSON (OpBlock ops) = J.object [ "actions" .= ops ]++instance J.FromJSON Operation where+ parseJSON (J.Object o) = do+ a <- o .: "action"+ case () of+ () | a == t"insert" -> InsertAfter <$> o .: "after" <*> o .: "id" <*> o .: "ch"+ () | a == t"remove" -> Remove <$> o .: "atom"+ () | otherwise -> mzero+ parseJSON _ = mzero++instance J.ToJSON Operation where+ toJSON (InsertAfter after aid ch) = J.object [ "action" .= t"insert", "after" .= after, "id" .= aid, "ch" .= ch ]+ toJSON (Remove aid) = J.object [ "action" .= t"remove", "id" .= aid]++---+++receiveJson :: J.FromJSON a => WS.WebSockets WS.Hybi00 a+receiveJson = do+ bs <- WS.receiveData+ case J.decode' bs of+ Nothing -> sendJson (jsonError "invalid message") >> receiveJson+ Just a -> return a++sendJson :: J.ToJSON a => a -> WS.WebSockets WS.Hybi00 ()+sendJson j = do+ msg <- mkJsonMsg (J.toJSON j)+ WS.sendTextData (LTE.decodeUtf8 $ J.encode msg)++sendSinkJson :: (MonadIO m, J.ToJSON a) => WS.Sink WS.Hybi00 -> a -> m ()+sendSinkJson sink j = do+ msg <- mkJsonMsg (J.toJSON j)+ liftIO $ WS.sendSink sink $ WS.textData (LTE.decodeUtf8 $ J.encode msg)++-- if we send an object, and it does not have a time field, inject it+mkJsonMsg :: MonadIO m => Value -> m J.Value+mkJsonMsg (J.Object o) | not (HM.member "time" o) = do+ t <- getTimestamp+ return $ J.Object (HM.insert "time" (J.toJSON t) o)+mkJsonMsg x = return x++jsonError :: String -> J.Value+jsonError msg = J.object [ "error" .= msg ]++sockets :: Editor -> WS.Request -> WS.WebSockets WS.Hybi00 ()+sockets y req+ | WS.requestPath req == "/edit" = accept editSocket+ | otherwise = WS.rejectRequest req "Not found"+ where+ accept a = WS.acceptRequest req >> a y++editSocket :: Editor -> WS.WebSockets WS.Hybi00 ()+editSocket e = do+ client <- mkClientId e+ sendInit e client+ sink <- WS.getSink+ ch <- liftIO newChan+ t <- liftIO getTimestamp+ liftIO $ addClient e (Client t client ch)+ tid <- liftIO . forkIO . forever $ do+ acts <- readChan ch+ sendSinkJson sink acts+ forever $ do+ (OpBlock acts) <- receiveJson+ liftIO $ applyOps e acts+ return ()+ liftIO $ removeClient e client+ return ()++addClient :: Editor -> Client -> IO ()+addClient e c = modifyMVar_ (doc e) $ \(d, m) -> return (d, M.insert (clientId c) c m)++removeClient :: Editor -> ClientId -> IO ()+removeClient e cid = modifyMVar_ (doc e) $ \(d, m) -> return (d, M.delete cid m)++-- encode the whole document+currentVersion :: Document -> Value+currentVersion d =+ let xs = SM.toList d+ encodeAtom (a,v) = J.toJSON [ J.toJSON (aiTime a)+ , J.toJSON (aiClient a)+ , J.toJSON (taCh v)+ , J.toJSON (isJust $ taRemoved v)+ ]+ in J.toJSON $ map encodeAtom xs++sendInit :: Editor -> ClientId -> WS.WebSockets WS.Hybi00 ()+sendInit e c = do+ d <- liftIO (readMVar $ doc e)+ sendJson $ actions [ J.object [ "action" .= t"clientid", "clientId" .= c]+ , J.object [ "action" .= t"doc", "doc" .= currentVersion (fst d) ]+ ]++actions :: [J.Value] -> J.Value+actions as = J.object ["actions" .= as ]
+ src/Network/Web/GHCLive/Display.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Network.Web.GHCLive.Display where++import Data.Aeson (FromJSON, ToJSON, Value, (.:), (.=))+import qualified Data.Aeson as J+import qualified Data.Aeson as A+import Data.Aeson.TH+import qualified Data.Aeson.Types as J+import Data.Char+import Data.Word+import Data.Int+import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Typeable+import qualified Diagrams.Backend.SVG as D+import qualified Diagrams.Prelude as D+import GHC.Generics+import Text.Blaze.Html.Renderer.Text+import qualified Text.Blaze.Html5 as B+import Prelude hiding (span)++data ClientType = Html | Svg | Text deriving (Eq, Show, Enum)++instance J.ToJSON ClientType where toJSON = J.toJSON . map toLower . show++newtype DisplayResult = DisplayResult [DR] deriving (Eq, Monoid, Typeable, ToJSON)++-- instance ToJSON DisplayResult where toJSON (DisplayResult rs) = J.object [ T.pack "results" .= rs ]++data DR = DR {+ clientType :: ClientType, -- "SVG" "IMG" etc, changes how the browser-side javascript handles this result.+ result :: TL.Text -- actual result data+ } deriving (Eq, Show, Typeable)++instance ToJSON DR where toJSON (DR c r) = J.object [ T.pack "t" .= c, T.pack "r" .= r ]++text :: TL.Text -> DisplayResult+text x = DisplayResult [ DR Text x ]++html :: B.Markup -> DisplayResult+html x = DisplayResult [ DR Html (renderHtml x) ]++svg :: B.Markup -> DisplayResult+svg x = DisplayResult [ DR Svg (renderHtml x) ]++displayString :: String -> DisplayResult+displayString = text . TL.pack++displayChar :: Char -> DisplayResult+displayChar = displayString . return++displayListOf :: (a -> DisplayResult) -> [a] -> DisplayResult+displayListOf _ [] = displayString "[]"+displayListOf showx (x:xs) = displayChar '[' <> showx x <> showl xs+ where+ showl [] = displayChar ']'+ showl (y:ys) = displayChar ',' <> showx y <> showl ys++-- | Too fool ExtendedDefaultRules into firing+displaying :: (Display a, Show a) => a -> DisplayResult+displaying = display++class GDisplay f where+ gdisplay :: f a -> DisplayResult++instance GDisplay U1 where+ gdisplay U1 = mempty++instance Display a => GDisplay (K1 i a) where+ gdisplay (K1 a) = display a++instance (GDisplay f, GDisplay g) => GDisplay (f :+: g) where+ gdisplay (L1 f) = gdisplay f+ gdisplay (R1 g) = gdisplay g++instance (GDisplay f, GDisplay g) => GDisplay (f :*: g) where+ gdisplay (f :*: g) = gdisplay f <> displayChar ' ' <> gdisplay g++instance (Constructor c, GDisplay f) => GDisplay (M1 C c f) where+ gdisplay m@(M1 x) = displayString (conName m) <> displayChar ' ' <> gdisplay x++instance GDisplay f => GDisplay (M1 S c f) where+ gdisplay (M1 x) = gdisplay x++instance GDisplay f => GDisplay (M1 D c f) where+ gdisplay (M1 x) = gdisplay x++class Display a where+ displayList :: [a] -> DisplayResult+ displayList = displayListOf display++ display :: a -> DisplayResult+ default display :: (Generic a, GDisplay (Rep a)) => a -> DisplayResult+ display = gdisplay . from++{-+ default display :: Show a => a -> DisplayResult+ display = display . show+-}++displayEmpty :: DisplayResult+displayEmpty = DisplayResult []++renderMyDiagramToSvg :: Double -> D.Diagram D.SVG D.R2 -> B.Html+renderMyDiagramToSvg size dia =+ D.renderDia D.SVG (D.SVGOptions "output.file" (D.Dims size size)) dia++instance Display DisplayResult where+ display d = d++instance (a ~ D.SVG, b ~ D.R2, c ~ Any) => Display (D.QDiagram a b c) where+ display = svg . renderMyDiagramToSvg 150+ displayList = displayListOf (svg . renderMyDiagramToSvg 75)++instance Display TL.Text where+ display d = displayChar '"' <> text d <> displayChar '"'++instance Display T.Text where+ display d = displayChar '"' <> text (TL.fromStrict d) <> displayChar '"'++instance Display a => Display [a] where+ display = displayList++instance Display B.Markup where+ display d = html d++instance (Display a, Display b) => Display (a,b) where+ display (a, b) = displayChar '(' <> display a <> displayChar ',' <> display b <> displayChar ')'++instance (Display a, Display b, Display c) => Display (a,b,c) where+ display (a, b, c) = displayChar '(' <> display a <> displayChar ',' <> display b <> displayChar ',' <> display c <> displayChar ')'++instance Display Int where display = displayString . show+instance Display Int8 where display = displayString . show+instance Display Int16 where display = displayString . show+instance Display Int32 where display = displayString . show+instance Display Int64 where display = displayString . show+instance Display Word where display = displayString . show+instance Display Word8 where display = displayString . show+instance Display Word16 where display = displayString . show+instance Display Word32 where display = displayString . show+instance Display Word64 where display = displayString . show+instance Display Integer where display = displayString . show+instance Display Float where display = displayString . show+instance Display Double where display = displayString . show+instance Display Char where+ display = displayString . show+ displayList = display . TL.pack+instance Display () where display () = displayString "()"++-- generic instances+instance Display a => Display (Maybe a)+instance (Display a, Display b) => Display (Either a b)++-- orphans+instance Show B.Markup where+ show = TL.unpack . renderHtml++instance Show (D.QDiagram b v m) where+ showsPrec _ _ = showString "<diagram>"