agda-server-0.1: JS.hs

-- An interface to construct Exp, Stmt and Block data
--    (later: dedicated data types)

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE EmptyDataDecls #-}

module JS
    ( toExp
    , Exp
    , Stmt
    , setInnerHtml
    , getAgdaCode
    , button'
    ) where

import Param
import Memo

import Language.HJavaScript.Syntax
import Text.XHtml.Strict (form, action)

----------- type tags

data JIO a
data XML        -- for inner use
data Document   -- for inner use

-----------

instance JType (JIO a) where
instance JType XML where
instance JType Html where

instance IsExp Html HtmlStr where
    toExp = toExp . htmlStr

---------------

getAgdaCode :: Exp AreaID -> Exp AgdaCode
getAgdaCode = value_ . getElem

getElem :: Exp AreaID -> Exp XML
getElem = JCall $ JDeref document "getElementById"

value_ :: Exp XML -> Exp AgdaCode
value_ x = JDeref (Record_ x) "value"

setInnerHtml :: Exp ResID -> Exp HtmlStr -> Exp HtmlStr
setInnerHtml x y = JAssign (innerHtml_ x) y

innerHtml_ :: Exp ResID -> Var HtmlStr
innerHtml_ = innerHtml . getElem'

getElem' :: Exp ResID -> Exp XML
getElem' = JCall $ JDeref document "getElementById"

innerHtml :: Exp XML -> Var HtmlStr
innerHtml y = JDerefVar (Record_ y) "innerHTML"

---------------- for inner use

data Record_ a = Record_ (Exp a)

instance Show (Record_ a) where show (Record_ x) = show x
instance IsDeref (Record_ a)

document :: Record_ Document
document = Record_ $ JConst "document"

button' :: String -> Stmt () -> Html
button' title ac = form
        ! [ action $ "javascript:" ++ show ac
          ] << input ! [thetype "submit", value title]