module Graphics.UI.Threepenny.Internal.Types where
import Prelude hiding (init)
import Control.Applicative
import Control.Concurrent
import qualified Reactive.Threepenny as E
import Data.ByteString (ByteString, hPut)
import Data.Map (Map)
import Data.String (fromString)
import Data.Time
import Network.URI
import Text.JSON.Generic
import System.IO (stderr)
data Element = Element
{ elId :: ElementId
, elSession :: Session
}
instance Show Element where
show = show . elId
data ElementId = ElementId String
deriving (Data,Typeable,Show,Eq,Ord)
instance JSON ElementId where
showJSON (ElementId o) = showJSON o
readJSON obj = do
obj <- readJSON obj
ElementId <$> valFromObj "Element" obj
data Session = Session
{ sSignals :: Chan Signal
, sInstructions :: Chan Instruction
, sMutex :: MVar ()
, sEventHandlers :: MVar (Map EventKey (E.Handler EventData))
, sElementEvents :: MVar (Map ElementId ElementEvents)
, sEventQuit :: (E.Event (), E.Handler ())
, sClosures :: MVar [Integer]
, sElementIds :: MVar [Integer]
, sToken :: Integer
, sConnectedState :: MVar ConnectedState
, sThreadId :: ThreadId
, sStartInfo :: (URI,[(String,String)])
, sServerState :: ServerState
}
type Sessions = Map Integer Session
type MimeType = ByteString
type Filepaths = (Integer, Map ByteString (FilePath, MimeType))
type EventKey = (String, String)
type ElementEvents = String -> E.Event EventData
data ServerState = ServerState
{ sSessions :: MVar Sessions
, sFiles :: MVar Filepaths
, sDirs :: MVar Filepaths
}
type Window = Session
data ConnectedState
= Disconnected UTCTime
| Connected
deriving (Show)
data EventData = EventData [Maybe String]
data Config = Config
{ tpPort :: Int
, tpCustomHTML :: Maybe FilePath
, tpStatic :: Maybe FilePath
, tpLog :: ByteString -> IO ()
}
defaultConfig :: Config
defaultConfig = Config
{ tpPort = 10000
, tpCustomHTML = Nothing
, tpStatic = Nothing
, tpLog = \s -> hPut stderr s >> hPut stderr (fromString "\n")
}
data Instruction
= Debug String
| SetToken Integer
| GetElementsByClassName String
| GetElementsById [String]
| GetElementsByTagName String
| SetStyle ElementId [(String,String)]
| SetAttr ElementId String String
| Append ElementId ElementId
| SetText ElementId String
| SetHtml ElementId String
| Bind String ElementId Closure
| GetValue ElementId
| GetValues [ElementId]
| SetTitle String
| RunJSFunction String
| CallJSFunction String
| CallDeferredFunction (Closure,String,[String])
| EmptyEl ElementId
| Delete ElementId
deriving (Typeable,Data,Show)
instance JSON Instruction where
readJSON _ = error "JSON.Instruction.readJSON: No method implemented."
showJSON x = toJSON x
data Signal
= Quit ()
| Elements [ElementId]
| Event (String,String,[Maybe String])
| Value String
| Values [String]
| FunctionCallValues [Maybe String]
| FunctionResult JSValue
deriving (Typeable,Show)
instance JSON Signal where
showJSON _ = error "JSON.Signal.showJSON: No method implemented."
readJSON obj = do
obj <- readJSON obj
let quit = Quit <$> valFromObj "Quit" obj
elements = Elements <$> valFromObj "Elements" obj
event = do
(cid,typ,arguments) <- valFromObj "Event" obj
args <- mapM nullable arguments
return $ Event (cid,typ,args)
value = Value <$> valFromObj "Value" obj
values = Values <$> valFromObj "Values" obj
fcallvalues = do
FunctionCallValues <$> (valFromObj "FunctionCallValues" obj >>= mapM nullable)
fresult = FunctionResult <$> valFromObj "FunctionResult" obj
quit <|> elements <|> event <|> value <|> values <|> fcallvalues <|> fresult
nullable :: JSON a => JSValue -> Result (Maybe a)
nullable JSNull = return Nothing
nullable v = Just <$> readJSON v
data Closure = Closure EventKey
deriving (Typeable,Data,Show)
newtype JSCode = JSCode { unJSCode :: String }
deriving (Eq, Ord, Show, Data, Typeable)
class ToJS a where
render :: a -> JSCode
instance ToJS String where render = JSCode . show
instance ToJS Int where render = JSCode . show
instance ToJS Bool where render b = JSCode $ if b then "false" else "true"
instance ToJS JSValue where render x = JSCode $ showJSValue x ""
instance ToJS ElementId where
render (ElementId x) = apply "elidToElement(%1)" [render x]
instance ToJS Element where render (Element e _) = render e
data JSFunction a = JSFunction
{ code :: JSCode
, marshal :: Window -> JSValue -> Result a
}
instance Functor JSFunction where
fmap f = fmapWindow (const f)
fmapWindow :: (Window -> a -> b) -> JSFunction a -> JSFunction b
fmapWindow f (JSFunction c m) = JSFunction c (\w v -> f w <$> m w v)
fromJSCode :: JSCode -> JSFunction ()
fromJSCode c = JSFunction { code = c, marshal = \_ _ -> Ok () }
class FFI a where
fancy :: ([JSCode] -> JSCode) -> a
instance (ToJS a, FFI b) => FFI (a -> b) where
fancy f a = fancy $ f . (render a:)
instance FFI (JSFunction ()) where fancy f = fromJSCode $ f []
instance FFI (JSFunction String) where fancy = mkResult "%1.toString()"
instance FFI (JSFunction JSValue) where fancy = mkResult "%1"
instance FFI (JSFunction ElementId) where
fancy = mkResult "{ Element: elementToElid(%1) }"
instance FFI (JSFunction Element) where
fancy = fmapWindow (\w elid -> Element elid w) . fancy
mkResult :: JSON a => String -> ([JSCode] -> JSCode) -> JSFunction a
mkResult client f = JSFunction
{ code = apply client [f []]
, marshal = \w -> readJSON
}
ffi :: FFI a => String -> a
ffi macro = fancy (apply macro)
testFFI :: String -> Int -> JSFunction String
testFFI = ffi "$(%1).prop('checked',%2)"
apply :: String -> [JSCode] -> JSCode
apply code args = JSCode $ go code
where
argument i = unJSCode (args !! i)
go [] = []
go ('%':c:cs) = argument index ++ go cs
where index = fromEnum c fromEnum '1'
go (c:cs) = c : go cs