{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, QuasiQuotes, TypeSynonymInstances, OverloadedStrings, TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module HSP.JMacro where
import Control.Monad.Identity
import Control.Monad.Trans (lift)
import Control.Monad.State (MonadState(get,put))
import Data.Text.Lazy (Text, unpack)
import HSP.XML
import HSP.HTML4 (renderAsHTML)
import HSP.XMLGenerator
import HSP.Monad (HSPT(..))
import Language.Javascript.JMacro (JStat(..), JExpr(..), JVal(..), Ident(..), ToJExpr(..), toStat, jmacroE, jLam, jVarTy, jsToDoc, jsSaturate, renderPrefixJs)
import Text.PrettyPrint.Leijen.Text (Doc, displayT, renderOneLine)
class IntegerSupply m where
nextInteger :: m Integer
nextInteger' :: (MonadState Integer m) => m Integer
nextInteger' :: m Integer
nextInteger' =
do Integer
i <- m Integer
forall s (m :: * -> *). MonadState s m => m s
get
Integer -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Integer -> Integer
forall a. Enum a => a -> a
succ Integer
i)
Integer -> m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
i
instance (XMLGenerator m, IntegerSupply m, EmbedAsChild m Text, StringType m ~ Text) => EmbedAsChild m JStat where
asChild :: JStat -> GenChildList m
asChild JStat
jstat =
do Integer
i <- m Integer -> XMLGenT m Integer
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Integer
forall (m :: * -> *). IntegerSupply m => m Integer
nextInteger
XMLGenT m (XMLType m) -> GenChildList m
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild (XMLGenT m (XMLType m) -> GenChildList m)
-> XMLGenT m (XMLType m) -> GenChildList m
forall a b. (a -> b) -> a -> b
$ Name (StringType m)
-> [XMLGenT m [AttributeType m]]
-> [GenChildList m]
-> XMLGenT m (XMLType m)
forall (m :: * -> *).
XMLGen m =>
Name (StringType m)
-> [XMLGenT m [AttributeType m]]
-> [XMLGenT m [ChildType m]]
-> XMLGenT m (XMLType m)
genElement (Maybe (StringType m)
forall a. Maybe a
Nothing, String -> Text
fromStringLit String
"script")
[Attr Text Text -> XMLGenT m [AttributeType m]
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr ((String -> Text
fromStringLit String
"type" Text -> Text -> Attr Text Text
forall n a. n -> a -> Attr n a
:= String -> Text
fromStringLit String
"text/javascript") :: Attr Text Text)]
[Text -> GenChildList m
forall (m :: * -> *) c. EmbedAsChild m c => c -> GenChildList m
asChild (SimpleDoc -> Text
displayT (SimpleDoc -> Text) -> SimpleDoc -> Text
forall a b. (a -> b) -> a -> b
$ Doc -> SimpleDoc
renderOneLine (Doc -> SimpleDoc) -> Doc -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ String -> JStat -> Doc
forall a. (JsToDoc a, JMacro a) => String -> a -> Doc
renderPrefixJs (Integer -> String
forall a. Show a => a -> String
show Integer
i) JStat
jstat)]
instance (XMLGen m, IntegerSupply m, EmbedAsAttr m (Attr n Text)) => EmbedAsAttr m (Attr n JStat) where
asAttr :: Attr n JStat -> GenAttributeList m
asAttr (n
n := JStat
jstat) =
do Integer
i <- m Integer -> XMLGenT m Integer
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Integer
forall (m :: * -> *). IntegerSupply m => m Integer
nextInteger
Attr n Text -> GenAttributeList m
forall (m :: * -> *) a. EmbedAsAttr m a => a -> GenAttributeList m
asAttr (Attr n Text -> GenAttributeList m)
-> Attr n Text -> GenAttributeList m
forall a b. (a -> b) -> a -> b
$ (n
n n -> Text -> Attr n Text
forall n a. n -> a -> Attr n a
:= (SimpleDoc -> Text
displayT (SimpleDoc -> Text) -> SimpleDoc -> Text
forall a b. (a -> b) -> a -> b
$ Doc -> SimpleDoc
renderOneLine (Doc -> SimpleDoc) -> Doc -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ String -> JStat -> Doc
forall a. (JsToDoc a, JMacro a) => String -> a -> Doc
renderPrefixJs (Integer -> String
forall a. Show a => a -> String
show Integer
i) JStat
jstat))
type DOMNode = HSPT XML Identity XML
instance ToJExpr DOMNode where
toJExpr :: DOMNode -> JExpr
toJExpr = XML -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (XML -> JExpr) -> (DOMNode -> XML) -> DOMNode -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity XML -> XML
forall a. Identity a -> a
runIdentity (Identity XML -> XML)
-> (DOMNode -> Identity XML) -> DOMNode -> XML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DOMNode -> Identity XML
forall xml (m :: * -> *) a. HSPT xml m a -> m a
unHSPT
newtype XMLToInnerHTML = XMLToInnerHTML XML
instance ToJExpr XMLToInnerHTML where
toJExpr :: XMLToInnerHTML -> JExpr
toJExpr (XMLToInnerHTML XML
xml) =
[jmacroE| (function { var node = document.createElement('div')
; node.innerHTML = `(unpack $ renderAsHTML xml)`
; return node.childNodes[0]
})() |]
newtype XMLToDOM = XMLToDOM XML
instance ToJExpr XMLToDOM where
toJExpr :: XMLToDOM -> JExpr
toJExpr (XMLToDOM (Element (Namespace
dm', Text
n') Attributes
attrs Children
children)) =
let dm :: Maybe String
dm = (Text -> String) -> Namespace -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
unpack Namespace
dm'
n :: String
n = Text -> String
unpack Text
n'
in
[jmacroE| (function { var node = `(createElement (dm) (n))`
; `(map (setAttribute node) attrs)`
; `(map (appendChild node . XMLToDOM) children)`
; return node
})()
|]
where
createElement :: Maybe a -> a -> JExpr
createElement Maybe a
Nothing a
n = [jmacroE| document.createElement(`(n)`) |]
createElement (Just a
ns) a
n = [jmacroE| document.createElementNS(`(ns)`, `(n)`) |]
appendChild :: a -> a -> JExpr
appendChild a
node a
c' =
[jmacroE| (function () {
var c = `(c')`;
if (Object.prototype.toString.call(c) === '[object Array]') {
for (var i = 0; i < c.length; i++)
`(node)`.appendChild(c[i]);
} else {
`(node)`.appendChild(`(c)`);
}
})()
|]
setAttribute :: a -> Attribute -> JExpr
setAttribute a
node (MkAttr ((Namespace
Nothing, Text
nm'), (Value Bool
True Text
val'))) =
let nm :: String
nm = Text -> String
unpack Text
nm'
val :: String
val = Text -> String
unpack Text
val'
in
[jmacroE| `(node)`.setAttribute(`(nm)`, `(val)`) |]
setAttribute a
node (MkAttr ((Just Text
ns', Text
nm'), (Value Bool
True Text
val'))) =
let ns :: String
ns = Text -> String
unpack Text
ns'
nm :: String
nm = Text -> String
unpack Text
nm'
val :: String
val = Text -> String
unpack Text
val'
in
[jmacroE| `(node)`.setAttributeNS(`(ns)`, `(nm)`, `(val)`) |]
toJExpr (XMLToDOM (CDATA Bool
True Text
txt')) =
let txt :: String
txt = Text -> String
unpack Text
txt' in
[jmacroE| document.createTextNode(`(txt)`) |]
toJExpr (XMLToDOM (CDATA Bool
False Text
txt')) =
let txt :: String
txt = Text -> String
unpack Text
txt' in
[jmacroE| (function { var node = document.createElement('div')
; node.innerHTML = `(txt)`
; return node
})() |]
instance ToJExpr XML where
toJExpr :: XML -> JExpr
toJExpr = XMLToInnerHTML -> JExpr
forall a. ToJExpr a => a -> JExpr
toJExpr (XMLToInnerHTML -> JExpr)
-> (XML -> XMLToInnerHTML) -> XML -> JExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XML -> XMLToInnerHTML
XMLToInnerHTML