Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Progress toward REST interface

  • Loading branch information...
commit 8c855c5c135522471d25569d2db4db60d562b811 1 parent b1d2a99
@cdsmith authored
View
81 gloss-web-adapters/GlossAdapters.hs
@@ -1,41 +1,80 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE Safe #-}
module GlossAdapters where
import Graphics.Gloss
import Graphics.Gloss.Interface.Simulate
import Graphics.Gloss.Interface.Game
+import System.Random
+data World where
+ WPicture :: Picture -> World
+ WAnimation :: Float -> (Float -> Picture) -> World
+ WSimulation :: a
+ -> (Float -> a -> a)
+ -> (a -> Picture)
+ -> World
+ WGame :: a
+ -> (Float -> a -> a)
+ -> (Event -> a -> a)
+ -> (a -> Picture)
+ -> World
-data Simulation = forall a. Simulation
- a
- (Float -> a -> a)
- (a -> Picture)
+data WorldType = PictureType | AnimationType | SimulationType | GameType
+ deriving (Eq, Ord)
-advanceSimulation :: Float -> Simulation -> Simulation
-advanceSimulation dt (Simulation w s d) = Simulation (s dt w) s d
+typeOfWorld :: World -> WorldType
+typeOfWorld (WPicture _ ) = PictureType
+typeOfWorld (WAnimation _ _ ) = AnimationType
+typeOfWorld (WSimulation _ _ _ ) = SimulationType
+typeOfWorld (WGame _ _ _ _) = GameType
-simulationToPicture :: Simulation -> Picture
-simulationToPicture (Simulation w s d) = d w
+drawWorld :: World -> Picture
+drawWorld (WPicture p ) = p
+drawWorld (WAnimation t f ) = f t
+drawWorld (WSimulation w s d ) = d w
+drawWorld (WGame w s e d) = d w
-data Game = forall a. Game
- a
- (Event -> a -> a)
- (Float -> a -> a)
- (a -> Picture)
+stepWorld :: Float -> World -> World
+stepWorld dt (WPicture p ) = WPicture p
+stepWorld dt (WAnimation t f ) = WAnimation (t + dt) f
+stepWorld dt (WSimulation w s d ) = WSimulation (s dt w) s d
+stepWorld dt (WGame w s e d) = WGame (s dt w) s e d
-advanceGame :: Float -> Game -> Game
-advanceGame dt (Game w e s d) = Game (s dt w) e s d
+signalWorld :: Event -> World -> World
+signalWorld ev (WPicture p ) = WPicture p
+signalWorld ev (WAnimation t f ) = WAnimation t f
+signalWorld ev (WSimulation w s d ) = WSimulation w s d
+signalWorld ev (WGame w s e d) = WGame (e ev w) s e d
-signalGame :: Event -> Game -> Game
-signalGame ev (Game w e s d) = Game (e ev w) e s d
+type CompiledWorld = StdGen -> World
-gameToPicture :: Game -> Picture
-gameToPicture (Game w e s d) = d w
+
+worldFromPicture :: Picture -> CompiledWorld
+worldFromPicture = const . WPicture
+
+
+worldFromAnimation :: (Float -> Picture) -> CompiledWorld
+worldFromAnimation = const . WAnimation 0
+
+
+worldFromSimulation :: (StdGen -> a)
+ -> (Float -> a -> a)
+ -> (a -> Picture)
+ -> CompiledWorld
+worldFromSimulation i s d g = WSimulation (i g) s d
+
+
+worldFromGame :: (StdGen -> a)
+ -> (Float -> a -> a)
+ -> (Event -> a -> a)
+ -> (a -> Picture)
+ -> CompiledWorld
+worldFromGame i s e d g = WGame (i g) s e d
View
2  gloss-web-adapters/gloss-web-adapters.cabal
@@ -10,4 +10,4 @@ Cabal-version: >=1.2
Library
Exposed-modules: GlossAdapters
- Build-depends: base, gloss
+ Build-depends: base, gloss, random
View
1  gloss-web.cabal
@@ -41,6 +41,7 @@ Executable gloss-web
snap-server,
text,
time,
+ unordered-containers,
vector,
xmlhtml,
zlib
View
33 src/App.hs
@@ -4,7 +4,7 @@ import Control.Concurrent.MVar
import Data.Time
import Data.Word
import Graphics.Gloss
-import Snap.Types
+import Snap.Core
import System.Random
import Text.Templating.Heist
@@ -18,35 +18,20 @@ import qualified Data.ByteString.Base64 as B64
import GlossAdapters
import CacheMap
-
-type Anim = (Err (Float -> Picture), UTCTime, Float -> Picture)
-type Sim = (Err (StdGen -> Simulation), MVar (UTCTime, Simulation))
-type RunningGame = (Err (StdGen -> Game) , MVar (UTCTime, Word64, Game))
-
-type Err a = Either [String] a
+type CompileResult = ([String], Maybe CompiledWorld)
data App = App {
- appHeist :: TemplateState Snap,
- appAnimations :: CacheMap Int Anim,
- appSimulations :: CacheMap Int Sim,
- appGames :: CacheMap Int RunningGame,
- appCompiledPictures :: CacheMap ByteString (Err Picture),
- appCompiledAnimations :: CacheMap ByteString (Err (Float -> Picture)),
- appCompiledSimulations :: CacheMap ByteString (Err (StdGen -> Simulation)),
- appCompiledGames :: CacheMap ByteString (Err (StdGen -> Game))
+ appHeist :: HeistState Snap,
+ appSessions :: CacheMap Int (MVar (UTCTime, Int, World)),
+ appPrograms :: CacheMap (WorldType, ByteString) CompileResult
}
-newApp :: TemplateState Snap -> IO App
+newApp :: HeistState Snap -> IO App
newApp heist = do
- animMgr <- newCacheMap
- simMgr <- newCacheMap
- gameMgr <- newCacheMap
- cpic <- newCacheMap
- canim <- newCacheMap
- csim <- newCacheMap
- cgame <- newCacheMap
- return (App heist animMgr simMgr gameMgr cpic canim csim cgame)
+ sessions <- newCacheMap
+ programs <- newCacheMap
+ return (App heist sessions programs)
{-|
View
375 src/Main.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GADTs #-}
module Main where
import Blaze.ByteString.Builder
@@ -6,29 +7,38 @@ import Control.Applicative
import Control.Concurrent
import Control.Monad
import Control.Monad.Trans
-import Data.Aeson
-import Data.Aeson.Encode
import Data.IORef
+import Data.Maybe
import Data.Monoid
import Data.Time
import Graphics.Gloss
import Graphics.Gloss.Interface.Game
import Snap.Http.Server
-import Snap.Types
+import Snap.Core
import Snap.Util.FileServe
import System.Random
import Text.Templating.Heist
import Text.XmlHtml
import Data.ByteString (ByteString)
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as BC
-import qualified Data.ByteString.Lazy as LB
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as LB
+
import qualified Data.ByteString.Base64 as B64
import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Builder as LT
+
+import qualified Data.Aeson as A
+import qualified Data.Aeson.Encode as A
+
+import qualified Data.Vector as V
+
+import qualified Data.HashMap.Lazy as HM
import App
import EventStream
@@ -37,7 +47,6 @@ import Source
import Serialize
import GlossAdapters
-
main :: IO ()
main = do
Right heist <- loadTemplates "web" defaultHeistState
@@ -49,15 +58,142 @@ main = do
("game", game app),
("displayInBrowser", displayInBrowser app),
("animateInBrowser", animateInBrowser app),
- ("animateStream", animateStream app),
("simulateInBrowser", simulateInBrowser app),
- ("simulateStream", simulateStream app),
- ("gameInBrowser", gameInBrowser app),
- ("gameStream", gameStream app),
- ("gameEvent", gameEvent app) ]
+ ("gameInBrowser", gameInBrowser app),
+ ("playStream", playStream app),
+ ("playEvent", playEvent app),
+ ("api/:type", apiTop app),
+ ("api/:type/:hash", apiWorld app),
+ ("api/session/:sid", apiSession app) ]
<|> serveDirectory "web"
+toFullURL :: Text -> Snap Text
+toFullURL p = do
+ secure <- getsRequest rqIsSecure
+ host <- getsRequest rqServerName
+ port <- getsRequest rqServerPort
+ uri <- getsRequest rqURI
+ let scheme = if secure then "https" else "http"
+ let defPort | secure = 443
+ | otherwise = 80
+ let baseURI = fst $ T.breakOn "/api" (T.decodeUtf8 uri)
+ return $ scheme
+ <> "://"
+ <> T.decodeUtf8 host
+ <> if defPort == port then "" else ":" `mappend` T.pack (show port)
+ <> baseURI
+ <> p
+
+
+toWorldType :: ByteString -> WorldType
+toWorldType "picture" = PictureType
+toWorldType "animation" = AnimationType
+toWorldType "simulation" = SimulationType
+toWorldType "game" = GameType
+
+
+fromWorldType :: WorldType -> ByteString
+fromWorldType PictureType = "picture"
+fromWorldType AnimationType = "animation"
+fromWorldType SimulationType = "simulation"
+fromWorldType GameType = "game"
+
+
+compileWorld :: WorldType
+ -> Either ByteString ByteString
+ -> App
+ -> Snap (ByteString, ByteString, CompileResult)
+compileWorld typ src app = liftIO $ getCompileResult (appPrograms app) typ exp src
+ where exp = case typ of
+ PictureType -> "G.worldFromPicture picture :: G.CompiledWorld"
+ AnimationType -> "G.worldFromAnimation animation :: G.CompiledWorld"
+ SimulationType -> "G.worldFromSimulation initial step draw :: G.CompiledWorld"
+ GameType -> "G.worldFromGame initial step event draw :: G.CompiledWorld"
+
+
+apiTop :: App -> Snap ()
+apiTop app = method POST (compileNew app)
+
+
+apiWorld :: App -> Snap ()
+apiWorld app = method GET (retrieveSource app)
+ <|> method POST (startSession app)
+
+
+apiSession :: App -> Snap ()
+apiSession app = method GET (getWorldResult app)
+ <|> method POST (postEvent app)
+
+
+compileNew :: App -> Snap ()
+compileNew app = do
+ typeId <- maybe pass return =<< getParam "type"
+ src <- (B.concat . LB.toChunks) <$> readRequestBody maxSize
+
+ let typ = toWorldType typeId
+ (dig, _, res) <- compileWorld typ (Right src) app
+
+ sendProgInfo typ dig src res
+ where maxSize = 256 * 1024
+
+
+retrieveSource :: App -> Snap ()
+retrieveSource app = do
+ typeId <- maybe pass return =<< getParam "type"
+ digest <- maybe pass return =<< getParam "hash"
+
+ let typ = toWorldType typeId
+ let Just dig = B64.decodeLenient <$> urlDecode digest
+
+ (_, src, res) <- compileWorld typ (Left dig) app
+
+ sendProgInfo typ dig src res
+
+
+sendProgInfo :: WorldType -> ByteString -> ByteString -> CompileResult -> Snap ()
+sendProgInfo typ dig src (msgs, res) = do
+ when (dig == "") $ do
+ modifyResponse (setResponseCode 404)
+ finishWith =<< getResponse
+
+ url <- toFullURL $ "/api/" <> T.decodeUtf8 (fromWorldType typ) <> "/" <> encDig
+
+ props <- case res of
+ Nothing -> return [
+ ("success", A.Bool False)
+ ]
+ Just w -> do
+ g <- liftIO newStdGen
+ return [
+ ("success", A.Bool True),
+ ("picture", A.String $ T.decodeUtf8 $ toByteString
+ $ base64 $ fromPicture $ drawWorld $ w g),
+ ("session", A.Bool $ typ /= PictureType)
+ ]
+
+ modifyResponse $ setContentType "application/json"
+ writeLazyText $ LT.toLazyText $ A.fromValue $ A.Object $ HM.fromList $
+ props ++ [
+ ("uri", A.String $ url),
+ ("messages", A.Array $ V.fromList
+ $ map (A.String . T.pack) msgs)
+ ]
+ where encDig = T.decodeUtf8 $ urlEncode $ B64.encode dig
+
+
+startSession :: App -> Snap ()
+startSession = undefined
+
+
+getWorldResult :: App -> Snap ()
+getWorldResult = undefined
+
+
+postEvent :: App -> Snap ()
+postEvent = undefined
+
+
draw :: App -> Snap ()
draw app = do
Just (b,t) <- renderTemplate
@@ -185,198 +321,103 @@ getSource = (maybe pass (return . Right) =<< getParam "source")
<|> (maybe pass (return . Left . B64.decodeLenient) =<< getParam "digest")
-displayInBrowser :: App -> Snap ()
-displayInBrowser app = do
+doInBrowser :: WorldType
+ -> (Text -> App -> ByteString -> World -> Snap ())
+ -> App
+ -> Snap ()
+doInBrowser typ present app = do
src <- getSource
- (dig, res) <- liftIO $ getPicture app src
+ (dig, _, res) <- compileWorld typ src app
case res of
- Left errs -> errors app errs
- Right pic -> displayResult app dig pic
+ (errs, Nothing) -> errors app errs
+ (_, Just res) -> do g <- liftIO newStdGen
+ present handler app dig (res g)
+ where handler | typ == PictureType = "displayInBrowser"
+ | typ == AnimationType = "animateInBrowser"
+ | typ == SimulationType = "simulateInBrowser"
+ | typ == GameType = "gameInBrowser"
-displayResult :: App -> ByteString -> Picture -> Snap ()
-displayResult app dig pic = do
- Just (b, t) <- renderTemplate
- ( bindSplice "displayScript" (scrSplice pic)
- $ bindSplice "share" (shareLink "displayInBrowser" dig)
- $ appHeist app)
- "display"
- modifyResponse (setContentType t)
- writeBuilder b
- where
- scrSplice pic = return [ Element "script" [("type", "text/javascript")] [
- TextNode "picture = '",
- TextNode $ T.decodeUtf8 $ toByteString $ base64 $ fromPicture pic,
- TextNode "';"
- ]]
+displayInBrowser :: App -> Snap ()
+displayInBrowser = doInBrowser PictureType displayResult
animateInBrowser :: App -> Snap ()
-animateInBrowser app = do
- src <- getSource
- (dig, res) <- liftIO $ getAnimation app src
- case res of
- Left errs -> errors app errs
- Right pic -> animateResult app dig res pic
+animateInBrowser = doInBrowser AnimationType playResult
-animateResult :: App -> ByteString -> Err (Float -> Picture) -> (Float -> Picture) -> Snap ()
-animateResult app dig e f = do
- t <- liftIO getCurrentTime
- let anim = (e, t, f)
- k <- liftIO $ cacheNew (appAnimations app) anim
- liftIO $ keepAlive (appAnimations app) k 30
- Just (b, t) <- renderTemplate
- ( bindSplice "displayScript" (scrSplice k)
- $ bindSplice "share" (shareLink "animateInBrowser" dig)
- $ appHeist app)
- "display"
- modifyResponse (setContentType t)
- writeBuilder b
- where
- scrSplice k = return [ Element "script" [("type", "text/javascript")] [
- TextNode "streamURI = \'animateStream?key=",
- TextNode $ T.pack $ show k,
- TextNode "\';"
- ]]
-
-
-animateStream :: App -> Snap ()
-animateStream app = do
- k <- fmap (read . BC.unpack) $ maybe pass return =<< getParam "key"
- (_, t0, f) <- maybe pass return =<< liftIO (getCached (appAnimations app) k)
- tv <- liftIO (newIORef =<< getCurrentTime)
- source <- cullDuplicates $ do
- keepAlive (appAnimations app) k 30
- t1 <- getCurrentTime
- t' <- readIORef tv
- let interval = t1 `diffUTCTime` t'
- when (interval < targetInterval) $
- threadDelay $ round $ 1000000 * (targetInterval - interval)
- t1 <- getCurrentTime
- writeIORef tv t1
- let t = realToFrac (t1 `diffUTCTime` t0)
- return (f t)
- eventStreamPull (fmap pictureEvent source)
- where
- targetInterval = 0.05
+simulateInBrowser :: App -> Snap ()
+simulateInBrowser = doInBrowser SimulationType playResult
-simulateInBrowser :: App -> Snap ()
-simulateInBrowser app = do
- src <- getSource
- (dig, res) <- liftIO $ getSimulation app src
- case res of
- Left errs -> errors app errs
- Right pic -> simulateResult app dig res pic
+gameInBrowser :: App -> Snap ()
+gameInBrowser = doInBrowser GameType playResult
-simulateResult :: App
- -> ByteString
- -> Err (StdGen -> Simulation)
- -> (StdGen -> Simulation)
- -> Snap ()
-simulateResult app dig e sim = do
- t <- liftIO getCurrentTime
- sim0 <- sim <$> liftIO newStdGen
- simul <- liftIO $ newMVar (t, sim0)
- k <- liftIO $ cacheNew (appSimulations app) (e, simul)
- liftIO $ keepAlive (appSimulations app) k 30
+displayResult :: Text -> App -> ByteString -> World -> Snap ()
+displayResult typ app dig w = do
+ let pic = drawWorld w
Just (b, t) <- renderTemplate
- ( bindSplice "displayScript" (scrSplice k)
- $ bindSplice "share" (shareLink "simulateInBrowser" dig)
+ ( bindSplice "displayScript" (scrSplice pic)
+ $ bindSplice "share" (shareLink typ dig)
$ appHeist app)
"display"
modifyResponse (setContentType t)
writeBuilder b
where
- scrSplice k = return [ Element "script" [("type", "text/javascript")] [
- TextNode "streamURI = \'simulateStream?key=",
- TextNode $ T.pack $ show k,
- TextNode "\';"
+ scrSplice pic = return [ Element "script" [("type", "text/javascript")] [
+ TextNode "picture = '",
+ TextNode $ T.decodeUtf8 $ toByteString $ base64 $ fromPicture pic,
+ TextNode "';"
]]
-simulateStream :: App -> Snap ()
-simulateStream app = do
- k <- fmap (read . BC.unpack) $ maybe pass return =<< getParam "key"
- (_, var) <- maybe pass return =<< liftIO (getCached (appSimulations app) k)
- source <- cullDuplicates $ modifyMVar var $ \(t0, sim) -> do
- keepAlive (appSimulations app) k 30
- t1 <- getCurrentTime
- let interval = t1 `diffUTCTime` t0
- when (interval < targetInterval) $
- threadDelay $ round $ 1000000 * (targetInterval - interval)
- t1 <- getCurrentTime
- let t = realToFrac (t1 `diffUTCTime` t0)
- let sim' = advanceSimulation t sim
- let pic = simulationToPicture sim'
- return ((t1, sim'), pic)
- eventStreamPull (fmap pictureEvent source)
- where
- targetInterval = 0.05
-
-
-gameInBrowser :: App -> Snap ()
-gameInBrowser app = do
- src <- getSource
- (dig, res) <- liftIO $ getGame app src
- case res of
- Left errs -> errors app errs
- Right pic -> runGame app dig res pic
-
-
-runGame :: App
- -> ByteString
- -> Err (StdGen -> Game)
- -> (StdGen -> Game)
- -> Snap ()
-runGame app dig e game = do
+playResult :: Text -> App -> ByteString -> World -> Snap ()
+playResult typ app dig w = do
t <- liftIO getCurrentTime
- g0 <- game <$> liftIO newStdGen
- gvar <- liftIO $ newMVar (t, 0, g0)
- k <- liftIO $ cacheNew (appGames app) (e, gvar)
- liftIO $ keepAlive (appGames app) k 30
- Just (b, t) <- renderTemplate
+ wvar <- liftIO $ newMVar (t, 0, w)
+ k <- liftIO $ cacheNew (appSessions app) wvar
+ liftIO $ keepAlive (appSessions app) k 30
+ Just (b, ct) <- renderTemplate
( bindSplice "displayScript" (scrSplice k)
- $ bindSplice "share" (shareLink "gameInBrowser" dig)
+ $ bindSplice "share" (shareLink typ dig)
$ appHeist app)
"display"
- modifyResponse (setContentType t)
+ modifyResponse (setContentType ct)
writeBuilder b
where
scrSplice k = return [ Element "script" [("type", "text/javascript")] [
- TextNode "streamURI = \'gameStream?key=",
+ TextNode "streamURI = \'playStream?key=",
TextNode $ T.pack $ show k,
TextNode "\';",
- TextNode "eventURI = \'gameEvent?key=",
+ TextNode "eventURI = \'playEvent?key=",
TextNode $ T.pack $ show k,
TextNode "\';"
]]
-gameStream :: App -> Snap ()
-gameStream app = do
- k <- fmap (read . BC.unpack) $ maybe pass return =<< getParam "key"
- (_, var) <- maybe pass return =<< liftIO (getCached (appGames app) k)
- source <- cullDuplicates $ modifyMVar var $ \(t0, prev, game) -> do
- keepAlive (appGames app) k 30
+playStream :: App -> Snap ()
+playStream app = do
+ k <- fmap (read . BC.unpack) $ maybe pass return =<< getParam "key"
+ var <- maybe pass return =<< liftIO (getCached (appSessions app) k)
+ source <- cullDuplicates $ modifyMVar var $ \(t0, prev, w) -> do
+ keepAlive (appSessions app) k 30
t1 <- getCurrentTime
let interval = t1 `diffUTCTime` t0
when (interval < targetInterval) $
threadDelay $ round $ 1000000 * (targetInterval - interval)
t1 <- getCurrentTime
- let t = realToFrac (t1 `diffUTCTime` t0)
- let game' = advanceGame t game
- let pic = gameToPicture game'
- return ((t1, prev, game'), pic)
+ let dt = realToFrac (t1 `diffUTCTime` t0)
+ let w' = stepWorld dt w
+ let pic = drawWorld w'
+ return ((t1, prev, w'), pic)
eventStreamPull (fmap pictureEvent source)
where
targetInterval = 0.05
-gameEvent :: App -> Snap ()
-gameEvent app = do
+playEvent :: App -> Snap ()
+playEvent app = do
nstr <- maybe pass return =<< getParam "n"
case reads (BC.unpack nstr) of
((n,"") : _) -> mapM_ handle [0 .. n-1]
@@ -406,16 +447,17 @@ gameEvent app = do
dispatch False $ EventMotion (x,y)
dispatch force event = do
- k <- fmap (read . BC.unpack) $ maybe pass return =<< getParam "key"
- ts <- fmap (read . BC.unpack) $ maybe pass return =<< getParam "ts"
- (_, var) <- maybe pass return =<< liftIO (getCached (appGames app) k)
- liftIO $ modifyMVar var $ \ (t0, prev, game) -> do
+ k <- fmap (read . BC.unpack) $ maybe pass return =<< getParam "key"
+ ts <- fmap (read . BC.unpack) $ maybe pass return =<< getParam "ts"
+ var <- maybe pass return =<< liftIO (getCached (appSessions app) k)
+ liftIO $ modifyMVar var $ \ (t0, prev, w) -> do
if force || ts >= prev
- then return ((t0, ts , signalGame event game), ())
- else return ((t0, prev, game ), ())
+ then return ((t0, ts , signalWorld event w), ())
+ else return ((t0, prev, w ), ())
pname s i = B.append s (BC.pack (show i))
+
bsToNum :: ByteString -> Snap Float
bsToNum bs = case reads (BC.unpack bs) of
[(f,"")] -> return f
@@ -496,4 +538,3 @@ errors app errs = do
shareLink handler digest = return [ TextNode link ]
where link = "/" `mappend` handler `mappend` "?digest="
`mappend` (T.decodeUtf8 $ urlEncode $ B64.encode digest)
-
View
119 src/Source.hs
@@ -2,11 +2,13 @@
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE OverloadedStrings #-}
module Source where
import Prelude hiding (catch)
+import Control.Applicative
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad
@@ -45,51 +47,6 @@ import ProtectHandlers
import ProfileSubst
-getPicture :: App -> Either ByteString ByteString -> IO (ByteString, Err Picture)
-getPicture _ _ = return (B.empty, Right picture)
-
-getAnimation :: App -> Either ByteString ByteString -> IO (ByteString, Err (Float -> Picture))
-getAnimation _ _ = return (B.empty, Right animation)
-
-getSimulation :: App -> Either ByteString ByteString -> IO (ByteString, Err (StdGen -> Simulation))
-getSimulation _ _ = return (B.empty, Right simulation)
-
-getGame :: App -> Either ByteString ByteString -> IO (ByteString, Err (StdGen -> Game))
-getGame _ _ = return (B.empty, Right game)
-
-#else
-
-getPicture :: App -> Either ByteString ByteString -> IO (ByteString, Err Picture)
-getPicture app src = do
- getCompileResult (appCompiledPictures app)
- "picture"
- "Picture"
- src
-
-
-getAnimation :: App -> Either ByteString ByteString -> IO (ByteString, Err (Float -> Picture))
-getAnimation app src = do
- getCompileResult (appCompiledAnimations app)
- "animation"
- "Float -> Picture"
- src
-
-
-getSimulation :: App -> Either ByteString ByteString -> IO (ByteString, Err (StdGen -> Simulation))
-getSimulation app src = do
- getCompileResult (appCompiledSimulations app)
- "(\\r -> Simulation (initial r) step draw)"
- "StdGen -> Simulation"
- src
-
-
-getGame :: App -> Either ByteString ByteString -> IO (ByteString, Err (StdGen -> Game))
-getGame app src = do
- getCompileResult (appCompiledGames app)
- "(\\r -> Game (initial r) event step draw)"
- "StdGen -> Game"
- src
-
#endif
@@ -98,34 +55,31 @@ getGame app src = do
is the cache, which should be different for different expected variables
and types
-}
-getCompileResult :: CacheMap ByteString (Err t)
- -> String
+getCompileResult :: CacheMap (WorldType, ByteString) CompileResult
+ -> WorldType
-> String
-> Either ByteString ByteString
- -> IO (ByteString, Err t)
-getCompileResult cmap vname tname inp = do
- r <- case source of
- Nothing -> do
- mr <- getCached cmap digest
- case mr of
- Nothing -> do
- e <- doesFileExist fname
- if e then cache cmap digest $ compile vname tname fname
- else return (Left [ "Program not found" ])
- Just r -> return r
- Just src -> do
- cache cmap digest $ do
- B.writeFile fname src
- compile vname tname fname
- keepAlive cmap digest 30
- return (digest, r)
+ -> IO (ByteString, ByteString, CompileResult)
+getCompileResult cmap typ expr inp = do
+ (dig, src, r) <- case inp of
+ Left dig -> do
+ e <- doesFileExist (fname dig)
+ if not e then return ("", "", ([], Nothing)) else do
+ mr <- getCached cmap (typ, dig)
+ src <- B.readFile (fname dig)
+ case mr of
+ Nothing -> (dig,src,) <$> cache cmap (typ, dig) (result dig)
+ Just r -> return (dig, src, r)
+ Right src -> do
+ let dig = hash src
+ (dig,src,) <$> (cache cmap (typ, dig) $ do
+ B.writeFile (fname dig) src
+ result dig)
+ keepAlive cmap (typ, dig) 30
+ return (dig, src, r)
where
- digest = case inp of Left digest -> digest
- Right src -> hash src
- source = case inp of Left _ -> Nothing
- Right src -> Just src
- fname = "tmp/" ++ base64FileName digest ++ ".hs"
-
+ fname digest = "tmp/" ++ base64FileName digest ++ ".hs"
+ result digest = compile expr (fname digest)
{-|
Runs an action in the 'Ghc' monad, and automatically collects error
@@ -133,12 +87,12 @@ getCompileResult cmap vname tname inp = do
it's a bit of tricky trial-and-error to handle them all uniformly, so
this function abstracts that.
-}
-doWithErrors :: GHC.Ghc (Maybe a) -> IO (Err a)
+doWithErrors :: GHC.Ghc (Maybe CompiledWorld) -> IO CompileResult
doWithErrors action = do
codeErrors <- newIORef []
protectHandlers $ catch (wrapper codeErrors) $ \ (e :: SomeException) -> do
errs <- readIORef codeErrors
- return (Left errs)
+ return (errs, Nothing)
where
wrapper codeErrors = fixupErrors codeErrors =<< do
GHC.defaultErrorHandler (logAction codeErrors)
@@ -160,8 +114,8 @@ doWithErrors action = do
cleaned = map (GHC.showSDoc . GHC.errMsgShortDoc) errs
GHC.liftIO $ modifyIORef ref (++ cleaned)
return Nothing
- fixupErrors errs (Just x) = return (Right x)
- fixupErrors errs Nothing = fmap Left (readIORef errs)
+ fixupErrors errs (Just x) = fmap (, Just x) (readIORef errs)
+ fixupErrors errs Nothing = fmap (, Nothing) (readIORef errs)
{-|
@@ -169,8 +123,8 @@ doWithErrors action = do
with the given type. If the type passed in doesn't match the way the
result is used, the server process will likely segfault.
-}
-compile :: String -> String -> FilePath -> IO (Err t)
-compile vname tname fn = doWithErrors $ do
+compile :: String -> FilePath -> IO CompileResult
+compile expr fn = doWithErrors $ do
dflags <- GHC.getSessionDynFlags
let dflags' = dflags {
GHC.ghcMode = GHC.CompManager,
@@ -190,13 +144,12 @@ compile vname tname fn = doWithErrors $ do
mods <- GHC.getModuleGraph
let mainMod = GHC.ms_mod (head mods)
GHC.setContext [ GHC.IIModule mainMod,
- GHC.IIDecl (GHC.simpleImportDecl
- (GHC.mkModuleName "Graphics.Gloss")),
- GHC.IIDecl (GHC.simpleImportDecl
- (GHC.mkModuleName "System.Random")),
- GHC.IIDecl (GHC.simpleImportDecl
- (GHC.mkModuleName "GlossAdapters")) ]
- v <- GHC.compileExpr $ vname ++ " :: " ++ tname
+ GHC.IIDecl (qualifiedImportDecl "GlossAdapters" "G") ]
+ v <- GHC.compileExpr expr
return (Just (unsafeCoerce# v))
False -> return Nothing
+qualifiedImportDecl m a = (GHC.simpleImportDecl (GHC.mkModuleName m)) {
+ GHC.ideclQualified = True,
+ GHC.ideclAs = Just (GHC.mkModuleName a)
+ }
Please sign in to comment.
Something went wrong with that request. Please try again.