-
Notifications
You must be signed in to change notification settings - Fork 0
/
API.hs
90 lines (70 loc) · 2.57 KB
/
API.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
{-# LANGUAGE LambdaCase, OverloadedStrings, KindSignatures, GADTs #-}
module HERMIT.API where
import Control.Applicative
import Control.Monad (void)
import Control.Lens ((^.))
import Data.Aeson
import Data.Aeson.Types
import Data.Maybe
import Control.Monad.Remote.JSON as JSONRPC
import Network.Wreq
import HERMIT.GHCI.JSON
{-
import HERMIT.GHCI.Session
-- | redisplays the current state to STDOUT.
display :: IO ()
display = shellEffect Display
-- Not exported, but useful
newtype ShellEffect :: * where
ShellEffect :: Value -> ShellEffect a
display' :: ShellEffect
display' = ShellEffect $ prim (mkName "HERMIT.display") $ []
newtype TypedEffectH :: * -> * where
TypedEffectH :: Value -> TypedEffectH a
shellEffect :: ShellEffect -> TypedEffectH
shellEffect = print 'ShellEffectH
prim :: Name -> [Value] -> Value
prim = undefined
-}
--- Main call-HERMIT function
class Shell f where
toShell :: f a -> Value
fromShell :: f a -> Value -> ShellResult a
data ShellResult a
= ShellResult [[Glyph]] a -- When was said, what was returned
| ShellFailure String -- something went wrong
deriving Show
instance FromJSON a => FromJSON (ShellResult a) where
parseJSON (Object o) = ShellResult <$> o .: "output"
<*> o .: "result"
<|> return (ShellFailure "malformed Object returned from Server")
parseJSON _ = return (ShellFailure "Object not returned from Server")
data ShellEffect :: * -> * where
ShellEffect :: Value -> ShellEffect ()
instance Shell ShellEffect where
toShell (ShellEffect v) = v
fromShell (ShellEffect {}) = fromJust . parseMaybe parseJSON
display :: ShellEffect ()
display = ShellEffect $ object ["method" .= ("display" :: String)]
session :: JSONRPC.Session
session = Session
{ sync = \ v -> do
r <- asJSON =<< post "http://localhost:3000/" (toJSON v)
return $ r ^. responseBody
, async = \ v -> do
post "http://localhost:3000/" (toJSON v)
return ()
}
send :: Shell f => f a -> IO a
send g = do
print (toShell g)
v <- JSONRPC.send session $ JSONRPC.method "send" [toShell g]
case fromShell g v of
ShellFailure msg -> error $ "failed to parse result value: " ++ show v ++ " : " ++ msg
ShellResult gss a -> do
sequence_ [ putStr txt
| gs <- gss
, Glyph txt _ <- gs
]
putStrLn "\n[Done]\n"
return a