Export functions for making Attributes

.gitignore

@@ -15,3 +15,5 @@
 .cabal-sandbox
 cabal.config
 cabal.sandbox.config
+.stack-work
+/TAGS

ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for ghcjs-vdom
+
+## 0.2.1.0 -- 2017-06-01
+
+* Add touch events: touchcancel, touchend, touchstart.

ghcjs-vdom.cabal

@@ -1,5 +1,5 @@
 name: ghcjs-vdom
-version: 0.2.0.0
+version: 0.2.1.0
 synopsis: Virtual-dom bindings for GHCJS
 description: Virtual-dom is a library for fast incremental DOM
  updates by comparing virtual immutable DOM trees to

jsbits/vdom.js

@@ -3,6 +3,7 @@
 /* 
  * global name for the things we need from the virtual-dom library
  */
+
 var h$vdom;
 
 function h$vdomEventCallback(async, action, ev) {

src/GHCJS/VDOM/Attribute.hs

@@ -2,6 +2,8 @@
 
 module GHCJS.VDOM.Attribute ( Attribute
  , Attributes
+ , mkAttributeFromList
+ , mkAttribute
  -- * some predefined attributes
  , class_
  , id
@@ -11,6 +13,7 @@ module GHCJS.VDOM.Attribute ( Attribute
  , name
  , target
  , value
+ , style
  , width
  , height
  , title
@@ -22,16 +25,24 @@ module GHCJS.VDOM.Attribute ( Attribute
 import Prelude hiding (id)
 
 import GHCJS.Types
-
+import qualified GHCJS.Prim.Internal.Build as IB
 import GHCJS.VDOM.Internal.Types
 import GHCJS.VDOM.Internal
-
+import Unsafe.Coerce
 mkAttrs ''JSString [ "id", "href", "src", "alt", "title"
- , "lang", "name", "target", "value"
+ , "lang", "name", "target", "value", "style"
  ]
 
 mkAttrs' ''JSString [ ("class_", "className")
  , ("type_", "type")
  ]
 
 mkAttrs ''Int [ "key", "width", "height" ]
+
+mkAttribute :: JSString -> JSVal -> Attribute
+mkAttribute = Attribute
+
+-- | For Proper Attributes in VDOM they must turn into an object
+mkAttributeFromList :: JSString -> [Attribute] -> Attribute
+mkAttributeFromList attrObjName attrList= mkAttribute attrObjName . IB.buildObjectI
+ . fmap (\(Attribute k v) -> (unsafeCoerce k,v)) $ attrList

src/GHCJS/VDOM/Element.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
 module GHCJS.VDOM.Element ( custom
+ , customNS
+ , customSVG
  , text
  , module GHCJS.VDOM.Element.Builtin
  ) where
@@ -14,3 +16,21 @@ import GHCJS.VDOM.Element.Builtin
 custom :: (Attributes a, Children c) => JSString -> a -> c -> VNode
 custom tag a c = I.mkVNode tag a c
 {-# INLINE custom #-}
+
+
+customNS :: (Attributes a, Children c) => JSString -> JSString -> a -> c -> VNode
+customNS ns tag a c = I.mkVNodeNS ns tag a c
+{-# INLINE customNS #-}
+
+
+
+customSVG :: (Attributes a, Children c) => JSString -> a -> c -> VNode
+customSVG tag a c = I.mkVNodeSVG tag a c
+{-# INLINE customSVG #-}
+
+
+
+
+
+
+

src/GHCJS/VDOM/Event.hs

@@ -28,13 +28,20 @@ module GHCJS.VDOM.Event ( initEventDelegation
  , buttons
  , clientX
  , clientY
+
+ -- * touch
+ , TouchEvent
+ , touchcancel
+ , touchend
+ , touchstart
 
  -- * keyboard
  , KeyboardEvent
  , keydown
  , keypress
  , keyup
  --
+ , input
  , key
  , ctrlKey
  , metaKey
@@ -95,9 +102,11 @@ initEventDelegation eventTypes = do
 class Coercible a JSVal => Event_ a
 class Event_ a => KeyModEvent_ a
 class Event_ a => MouseEvent_ a
+class Event_ a => TouchEvent_ a
 class Event_ a => FocusEvent_ a
 
 mkEventTypes ''Event_ [ ("MouseEvent", [''MouseEvent_])
+ , ("TouchEvent", [''TouchEvent_])
  , ("KeyboardEvent", [''KeyModEvent_])
  , ("FocusEvent", [''FocusEvent_])
  , ("DragEvent", [])
@@ -111,7 +120,9 @@ mkEvents 'MouseEvent [ "click", "dblclick", "mousedown", "mouseenter"
  , "mouseover", "mouseup"
  ]
 
-mkEvents 'KeyboardEvent [ "keydown", "keypress", "keyup" ]
+mkEvents 'TouchEvent ["touchcancel", "touchend", "touchstart"]
+
+mkEvents 'KeyboardEvent [ "keydown", "keypress", "keyup" ,"input"]
 
 mkEvents 'DragEvent [ "drag", "dragend", "dragenter", "dragleave"
  , "dragover", "dragstart" ]

src/GHCJS/VDOM/Internal.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -40,6 +41,16 @@ mkVNode :: (Attributes a, Children c) => JSString -> a -> c -> VNode
 mkVNode tag atts children = js_vnode tag (mkAttributes atts) (mkChildren children)
 {-# INLINE mkVNode #-}
 
+
+mkVNodeNS :: (Attributes a, Children c) => JSString -> JSString -> a -> c -> VNode
+mkVNodeNS ns tag atts children = js_vnode_ns ns tag (mkAttributes atts) (mkChildren children)
+{-# INLINE mkVNodeNS #-}
+
+mkVNodeSVG :: (Attributes a, Children c) => JSString -> a -> c -> VNode
+mkVNodeSVG tag atts children = js_vnode_svg tag (mkAttributes atts) (mkChildren children)
+{-# INLINE mkVNodeSVG #-}
+
+
 mkElems :: [String] -> Q [Dec]
 mkElems = fmap concat . mapM (join mkElem)
 
@@ -76,10 +87,19 @@ mkEventTypes base = fmap concat . mapM mk
  where
  mk (n, cls) = do
  let nn = mkName n
+#if MIN_VERSION_template_haskell(2,11,0)
+ mkI cn = InstanceD Nothing [] (AppT (ConT cn) (ConT nn)) []
+#else
  mkI cn = InstanceD [] (AppT (ConT cn) (ConT nn)) []
+#endif
  insts = map mkI (base : cls)
  jsr <- [t| JSVal |]
+#if MIN_VERSION_template_haskell(2,11,0)
+ typ <- [t| Typeable |]
+ return $ (NewtypeD [] nn [] Nothing (NormalC nn [(Bang NoSourceUnpackedness NoSourceStrictness, jsr)]) [ typ ]) : insts
+#else
  return $ (NewtypeD [] nn [] (NormalC nn [(NotStrict, jsr)]) [''Typeable]) : insts
+#endif
 
 newtype CreatedEvents = CreatedEvents { unCreatedEvents :: [String] }
  deriving (Typeable)
@@ -98,12 +118,21 @@ mkEvent dcon name attr = do
  emsg = "GHCJS.VDOM.Internal.mkEvent: expected newtype constructor"
  i <- reify dcon
  dctyp <- case i of
+#if MIN_VERSION_template_haskell(2,11,0)
+ DataConI _ _ pn -> do
+ pni <- reify pn
+ case pni of
+ TyConI (NewtypeD _ ctn _ _ _ _) -> return (ConT ctn)
+ _ -> error emsg
+ _ -> error emsg
+#else
  DataConI _ _ pn _ -> do
  pni <- reify pn
  case pni of
  TyConI (NewtypeD _ ctn _ _ _) -> return (ConT ctn)
  _ -> error emsg
  _ -> error emsg
+#endif
  iou <- [t| IO () |]
  h <- newName "h"
  b <- [| mkEventAttr (fromString attr) |]
@@ -118,7 +147,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'
@@ -136,11 +165,26 @@ 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) |]
- --VNode [jsu'| new h$vdom.VNode(`tag, `props, `children) |]
+js_vnode tag (Attributes' props) (Children' children) = VNode [jsu'| h$vdom.v(`tag, `props, `children) |]
+
+js_vnode_ns :: JSString -> JSString -> Attributes' -> Children' -> VNode
+js_vnode_ns ns tag (Attributes' props) (Children' children) = VNode [jsu'| new h$vdom.VNode(`tag, `props, `children) |]
+
+
+js_vnode_svg :: JSString -> Attributes' -> Children' -> VNode
+js_vnode_svg tag (Attributes' props) (Children' children) = VNode [jsu'|
+ (function () {
+ var attrs = `props.attributes;
+ for (attrName in attrs) {
+ `props[attrName] = attrs [attrName];
+ }
+ delete(`props.attributes);
+
+ return h$vdom.s(`tag, `props, `children);
+ } ())|]
+
 
 getThunk :: J -> IO J
 getThunk x = IO (js_getThunk x)
@@ -173,7 +217,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
 

src/GHCJS/VDOM/Internal/TH.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+{-# LANGUAGE CPP, TemplateHaskell, QuasiQuotes #-}
 
 module GHCJS.VDOM.Internal.TH where
 
@@ -27,11 +27,17 @@ mkTupleChildrenInstance cls method ty con wrapper n = do
  pat = [TupP (map (ConP con . (:[]) . VarP) xs)]
  body = NormalB (AppE (ConE wrapper)
  (foldl' (\e v -> AppE e (VarE v)) (VarE build) xs))
+#if MIN_VERSION_template_haskell(2,11,0)
+ return [InstanceD Nothing [] t [ FunD method [Clause pat body []]
+ , PragmaD (InlineP method Inline FunLike AllPhases)
+ ]
+ ]
+#else
  return [InstanceD [] t [ FunD method [Clause pat body []]
  , PragmaD (InlineP method Inline FunLike AllPhases)
  ]
  ]
- 
+#endif
 mkTupleAttrInstances :: Name -> Name -> Name -> Name -> Name -> [Int] -> Q [Dec]
 mkTupleAttrInstances cls method ty con wrapper xs =
  concat <$> mapM (mkTupleAttrInstance cls method ty con wrapper) xs
@@ -53,7 +59,14 @@ mkTupleAttrInstance cls method ty con wrapper n = do
  app e k v = AppE (AppE e (AppE (VarE 'unsafeCoerce) (VarE k))) (VarE v)
  body = NormalB (AppE (ConE wrapper)
  (foldl' (\e [k,v] -> app e k v) (VarE build) xs))
+#if MIN_VERSION_template_haskell(2,11,0)
+ return [InstanceD Nothing [] t [ FunD method [Clause pat body []]
+ , PragmaD (InlineP method Inline FunLike AllPhases)
+ ]
+ ]
+#else
  return [InstanceD [] t [ FunD method [Clause pat body []]
  , PragmaD (InlineP method Inline FunLike AllPhases)
  ]
  ]
+#endif

src/GHCJS/VDOM/Internal/Types.hs

@@ -5,8 +5,13 @@ module GHCJS.VDOM.Internal.Types where
 import qualified Data.JSString as JSS
 import Data.String (IsString(..))
 
+--ghcjs-base
 import GHCJS.Foreign.QQ
 import GHCJS.Types
+import GHCJS.Marshal
+
+--ghcjs
+import GHCJS.Prim
 import qualified GHCJS.Prim.Internal.Build
 import qualified GHCJS.Prim.Internal.Build as IB
 
@@ -67,7 +72,7 @@ instance Attributes () where
  {-# INLINE mkAttributes #-}
 
 instance Attributes Attribute where
- mkAttributes (Attribute k v) =
+ mkAttributes (Attribute k v) = 
  Attributes' (IB.buildObjectI1 (unsafeCoerce k) v)
 
 instance Attributes [Attribute] where

src/GHCJS/VDOM/QQ.hs

@@ -85,4 +85,3 @@ jsExpQQ pat args unwrap wrap = do
  qAddTopDecls [ffiDecl]
  qPutQ (QQCounter (c+1))
  return $ wrap (ffiCall $ reverse args)
-

src/GHCJS/VDOM/Unsafe.hs

@@ -4,7 +4,8 @@
  -}
 module GHCJS.VDOM.Unsafe ( Attributes(..), Children(..)
  , Attributes', Children'
- , unsafeToAttributes, unsafeToChildren ) where
+ , unsafeToAttributes, unsafeToChildren
+ , Attribute(..) ) where
 
 import GHCJS.Types
 

stack.yaml

@@ -0,0 +1,19 @@
+resolver: lts-7.8
+compiler: ghcjs-0.2.1.9007008_ghc-8.0.1
+compiler-check: match-exact
+
+setup-info:
+ ghcjs:
+ source:
+ ghcjs-0.2.1.9007008_ghc-8.0.1:
+ url: http://ghcjs.tolysz.org/ghc-8.0-2016-11-07-lts-7.8-9007008.tar.gz
+ sha1: 190300a3725cde44b2a08be9ef829f2077bf8825
+
+packages:
+- '.'
+- location:
+ git: [email protected]:ghcjs/ghcjs-ffiqq.git
+ commit: b52338c2dcd3b0707bc8aff2e171411614d4aedb
+ extra-dep: true
+
+extra-deps: []