0fd331b · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Add use-template-haskell flag

commit0fd331bd76b7c1503d8b61791323847de217e273 authorHamish Mackenzie <Hamish.K.Mackenzie@googlemail.com> dateThu 24 Nov 2016, 23:52 (10 years ago) parentbf99e40

9 files changed+107−21

compare with develop

unifiedsplit

reflex-dom.cabal+14−3 src-ghcjs/Reflex/Dom/Internal/Foreign.hs+1−1 src/Foreign/JavaScript/TH.hs+6−1 src/Reflex/Dom/Builder/Class.hs+30 src/Reflex/Dom/Builder/Class/Events.hs+13−1 src/Reflex/Dom/Builder/Immediate.hs+10 src/Reflex/Dom/Internal.hs+1−1 src/Reflex/Dom/Old.hs+11 src/Reflex/Dom/Widget/Input.hs+21−14

reflex-dom.cabal+14−3

@@ -19,6 +19,11 @@ extra-source-files: src-ghc/Reflex/Dom/Xhr/Foreign.hs

1919 src/Reflex/Dom/Xhr/ResponseType.hs

2020 src/Reflex/Dom/Xhr/Exception.hs

2121

22+flag use-template-haskell

23+ description: Use template haskell to generate lenses

24+ default: True

25+ manual: True

26+

2227flag use-reflex-optimizer

2328 description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.

2429 default: False

@@ -37,10 +42,10 @@ library

3742 contravariant >= 1.4 && < 1.5,

3843 data-default >= 0.5 && < 0.8,

3944 dependent-map == 0.2.*,

40− dependent-sum == 0.4.*,

45+ dependent-sum == 0.3.*,

4146 directory == 1.2.*,

4247 exception-transformers == 0.4.*,

43− ghcjs-dom >= 0.6.0.0 && < 0.7,

48+ ghcjs-dom >= 0.7.0.0 && < 0.8,

4449 -- keycode-0.2 has a bug on firefox

4550 keycode >= 0.2.1 && < 0.3,

4651 lens >= 4.7 && < 5,

@@ -68,7 +73,7 @@ library

6873 else

6974 hs-source-dirs: src-ghc

7075 build-depends:

71− jsaddle >=0.6.0.0 && <0.7

76+ jsaddle >=0.7.0.0 && <0.8

7277 if !os(windows)

7378 build-depends: unix == 2.7.*

7479

@@ -104,6 +109,12 @@ library

104109 if flag(use-reflex-optimizer)

105110 ghc-options: -fplugin=Reflex.Optimizer

106111

112+ if flag(use-template-haskell)

113+ build-depends:

114+ dependent-sum-template >= 0.0.0.5 && < 0.1

115+ other-extensions: TemplateHaskell

116+ cpp-options: -DUSE_TEMPLATE_HASKELL

117+

107118--test-suite hlint

108119-- build-depends: base, hlint == 1.9.*

109120-- hs-source-dirs: test

src-ghcjs/Reflex/Dom/Internal/Foreign.hs+1−1

@@ -18,7 +18,7 @@ import JavaScript.TypedArray.ArrayBuffer as JS

1818data WebView = WebView

1919

2020runWebGUI :: ((WebView, JSContextRef) -> IO ()) -> IO ()

21−runWebGUI main = run 0 (main (WebView, ()))

21+runWebGUI main = main (WebView, ())

2222

2323quitWebView :: WebView -> IO ()

2424quitWebView = error "quitWebView: unimplemented in GHCJS"

src/Foreign/JavaScript/TH.hs+6−1

@@ -9,6 +9,9 @@

99{-# LANGUAGE MultiParamTypeClasses #-}

1010{-# LANGUAGE RankNTypes #-}

1111{-# LANGUAGE StandaloneDeriving #-}

12+#ifdef USE_TEMPLATE_HASKELL

13+{-# LANGUAGE TemplateHaskell #-}

14+#endif

1215{-# LANGUAGE TypeFamilies #-}

1316{-# LANGUAGE TypeSynonymInstances #-}

1417{-# LANGUAGE UndecidableInstances #-}

@@ -53,6 +56,8 @@ import Data.Word

5356import Foreign.C.Types

5457import Foreign.Ptr

5558import Text.Encoding.Z

59+

60+import Reflex.Dom.Internal.Foreign (WebView)

5661#else

5762import Data.Word (Word8)

5863import Control.Lens.Operators ((^.))

@@ -490,7 +495,7 @@ instance ToJS x Node where

490495 withJS = withJSNode

491496

492497

493−#if 0

498+#ifdef USE_TEMPLATE_HASKELL

494499

495500importJS :: Safety -> String -> String -> Q Type -> Q [Dec]

496501importJS safety body name qt = do

src/Reflex/Dom/Builder/Class.hs+30

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE DefaultSignatures #-}

@@ -12,6 +13,9 @@

1213{-# LANGUAGE RankNTypes #-}

1314{-# LANGUAGE RecursiveDo #-}

1415{-# LANGUAGE ScopedTypeVariables #-}

16+#ifdef USE_TEMPLATE_HASKELL

17+{-# LANGUAGE TemplateHaskell #-}

18+#endif

1519{-# LANGUAGE TypeFamilies #-}

1620{-# LANGUAGE UndecidableInstances #-}

1721module Reflex.Dom.Builder.Class

@@ -150,6 +154,7 @@ data TextNodeConfig t

150154 , _textNodeConfig_setContents :: Event t Text

151155 }

152156

157+#ifndef USE_TEMPLATE_HASKELL

153158textNodeConfig_initialContents :: Lens' (TextNodeConfig t) Text

154159textNodeConfig_initialContents f (TextNodeConfig a b) = (\a' -> TextNodeConfig a' b) <$> f a

155160{-# INLINE textNodeConfig_initialContents #-}

@@ -160,6 +165,7 @@ textNodeConfig_setContents :: Lens

160165 (Event t2 Text)

161166textNodeConfig_setContents f (TextNodeConfig a b) = (\b' -> TextNodeConfig a b') <$> f b

162167{-# INLINE textNodeConfig_setContents #-}

168+#endif

163169

164170instance (Reflex t) => Default (TextNodeConfig t) where

165171 {-# INLINABLE def #-}

@@ -225,6 +231,7 @@ data ElementConfig er t m

225231 , _elementConfig_eventSpec :: EventSpec (DomBuilderSpace m) er

226232 }

227233

234+#ifndef USE_TEMPLATE_HASKELL

228235elementConfig_namespace :: Lens' (ElementConfig er t m) (Maybe Namespace)

229236elementConfig_namespace f (ElementConfig a b c d) = (\a' -> ElementConfig a' b c d) <$> f a

230237{-# INLINE elementConfig_namespace #-}

@@ -245,6 +252,7 @@ elementConfig_eventSpec :: Lens

245252 (EventSpec (DomBuilderSpace m2) er2)

246253elementConfig_eventSpec f (ElementConfig a b c d) = (\d' -> ElementConfig a b c d') <$> f d

247254{-# INLINE elementConfig_eventSpec #-}

255+#endif

248256

249257data Element er d t

250258 = Element { _element_events :: EventSelector t (WrapArg er EventName) --TODO: EventSelector should have two arguments

@@ -256,6 +264,7 @@ data PlaceholderConfig above t m

256264 , _placeholderConfig_deleteSelf :: Event t ()

257265 }

258266

267+#ifndef USE_TEMPLATE_HASKELL

259268placeholderConfig_insertAbove :: Lens

260269 (PlaceholderConfig above1 t m1)

261270 (PlaceholderConfig above2 t m2)

@@ -266,6 +275,7 @@ placeholderConfig_insertAbove f (PlaceholderConfig a b) = (\a' -> PlaceholderCon

266275placeholderConfig_deleteSelf :: Lens' (PlaceholderConfig above t m) (Event t ())

267276placeholderConfig_deleteSelf f (PlaceholderConfig a b) = (\b' -> PlaceholderConfig a b') <$> f b

268277{-# INLINE placeholderConfig_deleteSelf #-}

278+#endif

269279

270280instance Reflex t => Default (PlaceholderConfig above t m) where

271281 {-# INLINABLE def #-}

@@ -287,6 +297,7 @@ data InputElementConfig er t m

287297 , _inputElementConfig_elementConfig :: ElementConfig er t m

288298 }

289299

300+#ifndef USE_TEMPLATE_HASKELL

290301inputElementConfig_initialValue :: Lens' (InputElementConfig er t m) Text

291302inputElementConfig_initialValue f (InputElementConfig a b c d e) = (\a' -> InputElementConfig a' b c d e) <$> f a

292303{-# INLINE inputElementConfig_initialValue #-}

@@ -306,6 +317,7 @@ inputElementConfig_elementConfig :: Lens

306317 (ElementConfig er2 t m2)

307318inputElementConfig_elementConfig f (InputElementConfig a b c d e) = (\e' -> InputElementConfig a b c d e') <$> f e

308319{-# INLINE inputElementConfig_elementConfig #-}

320+#endif

309321

310322instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (InputElementConfig er t m) where

311323 {-# INLINABLE def #-}

@@ -334,6 +346,7 @@ data TextAreaElementConfig er t m

334346 , _textAreaElementConfig_elementConfig :: ElementConfig er t m

335347 }

336348

349+#ifndef USE_TEMPLATE_HASKELL

337350textAreaElementConfig_initialValue :: Lens' (TextAreaElementConfig er t m) Text

338351textAreaElementConfig_initialValue f (TextAreaElementConfig a b c) = (\a' -> TextAreaElementConfig a' b c) <$> f a

339352{-# INLINE textAreaElementConfig_initialValue #-}

@@ -347,6 +360,7 @@ textAreaElementConfig_elementConfig :: Lens

347360 (ElementConfig er2 t m2)

348361textAreaElementConfig_elementConfig f (TextAreaElementConfig a b c) = (\c' -> TextAreaElementConfig a b c') <$> f c

349362{-# INLINE textAreaElementConfig_elementConfig #-}

363+#endif

350364

351365instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (TextAreaElementConfig er t m) where

352366 {-# INLINABLE def #-}

@@ -375,6 +389,7 @@ data RawElementConfig er t m = RawElementConfig

375389 , _rawElementConfig_eventSpec :: EventSpec (DomBuilderSpace m) er

376390 }

377391

392+#ifndef USE_TEMPLATE_HASKELL

378393rawElementConfig_modifyAttributes :: Lens

379394 (RawElementConfig er t1 m)

380395 (RawElementConfig er t2 m)

@@ -389,6 +404,7 @@ rawElementConfig_eventSpec :: Lens

389404 (EventSpec (DomBuilderSpace m2) er2)

390405rawElementConfig_eventSpec f (RawElementConfig a b) = (\b' -> RawElementConfig a b') <$> f b

391406{-# INLINE rawElementConfig_eventSpec #-}

407+#endif

392408

393409instance (Reflex t, DomSpace (DomBuilderSpace m)) => Default (RawElementConfig EventResult t m) where

394410 def = RawElementConfig

@@ -402,6 +418,7 @@ data SelectElementConfig er t m = SelectElementConfig

402418 , _selectElementConfig_elementConfig :: ElementConfig er t m

403419 }

404420

421+#ifndef USE_TEMPLATE_HASKELL

405422selectElementConfig_initialValue :: Lens' (SelectElementConfig er t m) Text

406423selectElementConfig_initialValue f (SelectElementConfig a b c) = (\a' -> SelectElementConfig a' b c) <$> f a

407424{-# INLINE selectElementConfig_initialValue #-}

@@ -415,6 +432,7 @@ selectElementConfig_elementConfig :: Lens

415432 (ElementConfig er2 t m2)

416433selectElementConfig_elementConfig f (SelectElementConfig a b c) = (\c' -> SelectElementConfig a b c') <$> f c

417434{-# INLINE selectElementConfig_elementConfig #-}

435+#endif

418436

419437instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (SelectElementConfig er t m) where

420438 def = SelectElementConfig

@@ -431,6 +449,18 @@ data SelectElement er d t = SelectElement

431449 , _selectElement_raw :: RawSelectElement d

432450 }

433451

452+#ifdef USE_TEMPLATE_HASKELL

453+concat <$> mapM makeLenses

454+ [ ''TextNodeConfig

455+ , ''ElementConfig

456+ , ''PlaceholderConfig

457+ , ''InputElementConfig

458+ , ''TextAreaElementConfig

459+ , ''SelectElementConfig

460+ , ''RawElementConfig

461+ ]

462+#endif

463+

434464class CanDeleteSelf t a | a -> t where

435465 deleteSelf :: Lens' a (Event t ())

436466

src/Reflex/Dom/Builder/Class/Events.hs+13−1

@@ -1,13 +1,21 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DataKinds #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE KindSignatures #-}

45{-# LANGUAGE PolyKinds #-}

6+#ifdef USE_TEMPLATE_HASKELL

7+{-# LANGUAGE TemplateHaskell #-}

8+#endif

59{-# LANGUAGE TypeFamilies #-}

610module Reflex.Dom.Builder.Class.Events where

711

12+#ifdef USE_TEMPLATE_HASKELL

13+import Data.GADT.Compare.TH

14+#else

815import Data.GADT.Compare

916 (GOrdering(..), (:~:)(..), GEq(..), GCompare(..))

1017import Control.Monad (ap)

18+#endif

1119

1220data EventTag

1321 = AbortTag

@@ -155,6 +163,10 @@ type family EventResultType (en :: EventTag) :: * where

155163 EventResultType 'TouchcancelTag = ()

156164 EventResultType 'WheelTag = ()

157165

166+#ifdef USE_TEMPLATE_HASKELL

167+deriveGEq ''EventName

168+deriveGCompare ''EventName

169+#else

158170instance GEq EventName

159171 where geq Abort Abort = return Refl

160172 geq Blur Blur = return Refl

@@ -356,4 +368,4 @@ instance GCompare EventName

356368 gcompare Touchcancel Touchcancel = runGComparing $ return GEQ

357369 gcompare Touchcancel _ = GLT

358370 gcompare _ Touchcancel = GGT

359−

371+#endif

src/Reflex/Dom/Builder/Immediate.hs+10

@@ -12,6 +12,9 @@

1212{-# LANGUAGE RankNTypes #-}

1313{-# LANGUAGE RecursiveDo #-}

1414{-# LANGUAGE ScopedTypeVariables #-}

15+#ifdef USE_TEMPLATE_HASKELL

16+{-# LANGUAGE TemplateHaskell #-}

17+#endif

1518{-# LANGUAGE TypeFamilies #-}

1619{-# LANGUAGE TypeOperators #-}

1720{-# LANGUAGE UndecidableInstances #-}

@@ -34,7 +37,9 @@ import Control.Monad.Primitive

3437import Control.Monad.Reader

3538import Control.Monad.Ref

3639import Control.Monad.Trans.Control

40+#ifndef USE_TEMPLATE_HASKELL

3741import Data.Functor.Contravariant (phantom)

42+#endif

3843import Data.Bitraversable

3944import Data.Default

4045import Data.Dependent.Map (DMap)

@@ -283,6 +288,7 @@ data GhcjsEventSpec er = GhcjsEventSpec

283288 , _ghcjsEventSpec_handler :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en))

284289 }

285290

291+#ifndef USE_TEMPLATE_HASKELL

286292phantom2 :: (Functor f, Contravariant f) => f a -> f b

287293phantom2 = phantom

288294{-# INLINE phantom2 #-}

@@ -293,6 +299,7 @@ ghcjsEventSpec_filters f (GhcjsEventSpec a b) = (\a' -> GhcjsEventSpec a' b) <$>

293299ghcjsEventSpec_handler :: forall er en . Getter (GhcjsEventSpec er) ((EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)))

294300ghcjsEventSpec_handler f (GhcjsEventSpec _ b) = phantom2 (f b)

295301{-# INLINE ghcjsEventSpec_handler #-}

302+#endif

296303

297304instance er ~ EventResult => Default (GhcjsEventSpec er) where

298305 def = GhcjsEventSpec

@@ -993,3 +1000,6 @@ wrapWindow wv _ = do

9931000 , _window_raw = wv

9941001 }

9951002

1003+#ifdef USE_TEMPLATE_HASKELL

1004+makeLenses ''GhcjsEventSpec

1005+#endif

src/Reflex/Dom/Internal.hs+1−1

@@ -44,7 +44,7 @@ import GHCJS.DOM.Document

4444import GHCJS.DOM.Element

4545import GHCJS.DOM.Node

4646import qualified GHCJS.DOM.Types as DOM

47−import GHCJS.DOM.Types (MonadJSM(..), runJSM, askJSM, JSM)

47+import GHCJS.DOM.Types (MonadJSM(..), JSM)

4848

4949{-# INLINABLE mainWidget #-}

5050mainWidget :: (forall x. Widget x ()) -> JSM ()

src/Reflex/Dom/Old.hs+11

@@ -9,6 +9,9 @@

99{-# LANGUAGE TypeFamilies #-}

1010{-# LANGUAGE UndecidableInstances #-}

1111{-# LANGUAGE LambdaCase #-}

12+#ifdef USE_TEMPLATE_HASKELL

13+{-# LANGUAGE TemplateHaskell #-}

14+#endif

1215module Reflex.Dom.Old

1316 ( MonadWidget

1417 , El

@@ -43,7 +46,11 @@ module Reflex.Dom.Old

4346 ) where

4447

4548import Control.Arrow (first)

49+#ifdef USE_TEMPLATE_HASKELL

50+import Control.Lens (makeLenses, (%~), (&), (.~), (^.))

51+#else

4652import Control.Lens (Lens, Lens', (%~), (&), (.~), (^.))

53+#endif

4754import Control.Monad

4855import Control.Monad.Fix

4956import Control.Monad.IO.Class

@@ -86,12 +93,16 @@ instance attrs ~ Map Text Text => Default (ElConfig attrs) where

8693 , _elConfig_attributes = mempty

8794 }

8895

96+#ifdef USE_TEMPLATE_HASKELL

97+makeLenses ''ElConfig

98+#else

8999elConfig_namespace :: Lens' (ElConfig attrs1) (Maybe Text)

90100elConfig_namespace f (ElConfig a b) = (\a' -> ElConfig a' b) <$> f a

91101{-# INLINE elConfig_namespace #-}

92102elConfig_attributes :: Lens (ElConfig attrs1) (ElConfig attrs2) attrs1 attrs2

93103elConfig_attributes f (ElConfig a b) = (\b' -> ElConfig a b') <$> f b

94104{-# INLINE elConfig_attributes #-}

105+#endif

95106

96107--TODO: HasDocument is still not accounted for

97108type MonadWidgetConstraints t m =

src/Reflex/Dom/Widget/Input.hs+21−14

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE FlexibleContexts #-}

@@ -8,6 +9,9 @@

89{-# LANGUAGE PolyKinds #-}

910{-# LANGUAGE RecursiveDo #-}

1011{-# LANGUAGE ScopedTypeVariables #-}

12+#ifdef USE_TEMPLATE_HASKELL

13+{-# LANGUAGE TemplateHaskell #-}

14+#endif

1115{-# LANGUAGE TypeFamilies #-}

1216{-# LANGUAGE UndecidableInstances #-}

1317module Reflex.Dom.Widget.Input (module Reflex.Dom.Widget.Input, def, (&), (.~)) where

@@ -443,20 +447,22 @@ dropdown k0 options (DropdownConfig setK attrs) = do

443447 dValue <- fmap (zipDynWith readKey ixKeys) $ holdDyn (Just k0) $ leftmost [eChange, fmap Just setK]

444448 return $ Dropdown dValue (attachPromptlyDynWith readKey ixKeys eChange)

445449

446−--concat <$> mapM makeLenses

447−-- [ ''TextAreaConfig

448−-- , ''TextArea

449−-- , ''TextInputConfig

450−-- , ''TextInput

451−-- , ''RangeInputConfig

452−-- , ''RangeInput

453−-- , ''FileInputConfig

454−-- , ''FileInput

455−-- , ''DropdownConfig

456−-- , ''Dropdown

457−-- , ''CheckboxConfig

458−-- , ''Checkbox

459−-- ]

450+#ifdef USE_TEMPLATE_HASKELL

451+concat <$> mapM makeLenses

452+ [ ''TextAreaConfig

453+ , ''TextArea

454+ , ''TextInputConfig

455+ , ''TextInput

456+ , ''RangeInputConfig

457+ , ''RangeInput

458+ , ''FileInputConfig

459+ , ''FileInput

460+ , ''DropdownConfig

461+ , ''Dropdown

462+ , ''CheckboxConfig

463+ , ''Checkbox

464+ ]

465+#else

460466textAreaConfig_attributes :: Lens' (TextAreaConfig t) (Dynamic t (Map Text Text))

461467textAreaConfig_attributes f (TextAreaConfig x1 x2 x3) = (\y -> TextAreaConfig x1 x2 y) <$> f x3

462468{-# INLINE textAreaConfig_attributes #-}

@@ -587,6 +593,7 @@ checkbox_change f (Checkbox x1 x2) = (\y -> Checkbox x1 y) <$> f x2

587593checkbox_value :: Lens' (Checkbox t) (Dynamic t Bool)

588594checkbox_value f (Checkbox x1 x2) = (\y -> Checkbox y x2) <$> f x1

589595{-# INLINE checkbox_value #-}

596+#endif

590597

591598instance HasAttributes (TextAreaConfig t) where

592599 type Attrs (TextAreaConfig t) = Dynamic t (Map Text Text)