Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Allow definition of custom attributes #14

Closed
wants to merge 5 commits into from
Closed
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions .gitignore
Original file line number Diff line number Diff line change
Expand Up @@ -15,3 +15,4 @@
.cabal-sandbox
cabal.config
cabal.sandbox.config
.stack-work
4 changes: 2 additions & 2 deletions ghcjs-vdom.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -52,7 +52,7 @@ library
GHCJS.VDOM.QQ
GHCJS.VDOM.Render
GHCJS.VDOM.Unsafe
other-modules: GHCJS.VDOM.Internal
GHCJS.VDOM.Internal
GHCJS.VDOM.Internal.TH
GHCJS.VDOM.Internal.Thunk
GHCJS.VDOM.Internal.Types
Expand Down Expand Up @@ -105,4 +105,4 @@ executable ghcjs-vdom-example-render
ghcjs-vdom,
containers,
ghcjs-base
ghcjs-Options: -Wall
ghcjs-Options: -Wall
7 changes: 6 additions & 1 deletion src/GHCJS/VDOM/Attribute.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,8 +2,10 @@

module GHCJS.VDOM.Attribute ( Attribute
, Attributes
, custom
-- * some predefined attributes
, class_
, style
, id
, href
, alt
Expand All @@ -26,7 +28,10 @@ import GHCJS.Types
import GHCJS.VDOM.Internal.Types
import GHCJS.VDOM.Internal

mkAttrs ''JSString [ "id", "href", "src", "alt", "title"
custom :: JSString -> JSVal -> Attribute
custom = Attribute

mkAttrs ''JSString [ "id", "href", "src", "alt", "title", "style"
, "lang", "name", "target", "value"
]

Expand Down
13 changes: 8 additions & 5 deletions src/GHCJS/VDOM/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -61,13 +61,16 @@ mkAttrs ty = fmap concat . mapM (join (mkAttr ty))
mkAttrs' :: Name -> [(String, String)] -> Q [Dec]
mkAttrs' ty = fmap concat . mapM (uncurry (mkAttr ty))

-- mkAttr ''Int foo bar
-- Generates foo :: Int -> Attribute
-- foo x = (Attribute bar (pToJSVal x))
mkAttr :: Name -> String -> String -> Q [Dec]
mkAttr ty name attr = do
let n = mkName name
x <- newName "x"
b <- [| \y -> Attribute attr (pToJSVal y) |]
return [ SigD n (AppT (AppT ArrowT (ConT ty)) (ConT ''Attribute))
, FunD n [Clause [VarP x] (NormalB (AppE b (VarE x))) []]
return [ SigD n (AppT (AppT ArrowT (ConT ty)) (ConT ''Attribute)) -- `name :: ((`ty -> Attribute))
, FunD n [Clause [VarP x] (NormalB (AppE b (VarE x))) []] -- `name= (\y -> Attribute `attr (pToJSVal y))
, PragmaD (InlineP n Inline FunLike AllPhases)
]

Expand Down Expand Up @@ -118,7 +121,7 @@ mkEvent dcon name attr = do
-- a must be a newtype of JSVal!
mkEventAttr :: JSString -> (JSVal -> a) -> (a -> IO ()) -> Attribute
mkEventAttr attr _wrap h =

let e = unsafeExportValue h
h' = [js'| h$vdom.makeHandler(`e, false) |]
in h' `seq` Attribute attr h'
Expand All @@ -136,7 +139,7 @@ mkDefaultEvents = do
nil <- [| [] |]
cons <- [| (:) |]
return $ foldl' (\xs e -> AppE (AppE cons (LitE . stringL $ e)) xs) nil evs

js_vnode :: JSString -> Attributes' -> Children' -> VNode
js_vnode tag (Attributes' props) (Children' children) =
VNode [jsu'| h$vdom.v(`tag, `props, `children) |]
Expand Down Expand Up @@ -173,7 +176,7 @@ objectIdent x = x `seq` js_makeObjectIdent (unsafeExportValue x)
case makeStableName# x s of (# s', sn #) -> (# s', js_convertSn sn #)
-}
{-# INLINE objectIdent #-}

foreign import javascript unsafe "$r = $1;" js_export :: Any -> JSVal
foreign import javascript unsafe "$r = $1;" js_convertSn :: StableName# a -> JSIdent

Expand Down