c2c3f13 · reflex · git.iko.soy

git.iko.soy/reflex

Add factorDynGeneric

commitc2c3f1367bbdef0586c0b1efadb193b1600d0c0d authorRyan Trinkle <ryan.trinkle@gmail.com> dateWed 3 Jan 2018, 23:54 (9 years ago) parent264b370

11 files changed+523−23

compare with develop

unifiedsplit

.gitignore+1 default.nix+5−4 reflex.cabal+19−1 src/Generics/SOP/DMapUtilities.hs+184 src/Generics/SOP/Distribute.hs+120 src/Reflex/Dynamic.hs+53−12 src/Reflex/Dynamic/CollectDynGeneric.hs+64 src/Reflex/Dynamic/TH.hs+6−4 test/MkDyn.hs+38 test/Reflex/Test/TH.hs+26 test/semantics.hs+7−2

.gitignore+1

@@ -36,3 +36,4 @@ hsenv.log

3636/ghci-tmp

3737*.dump-*

3838*.verbose-core2core

39+.stack-work/*

default.nix+5−4

@@ -2,12 +2,13 @@

22, dependent-map, dependent-sum, exception-transformers

33, haskell-src-exts, haskell-src-meta, hlint, lens, MemoTrie

44, monad-control, mtl, primitive, random, ref-tf

5−, semigroupoids , semigroups, split, stdenv, stm, syb

6−, template-haskell , these, time, transformers

5+, semigroupoids, semigroups, split, stdenv, stm, syb

6+, template-haskell, these, time, transformers

77, transformers-compat, unbounded-delays, prim-uniq

8−, data-default , filepath, directory, filemanip

8+, data-default, filepath, directory, filemanip, generics-sop

99, useTemplateHaskell ? true

1010}:

11+

1112mkDerivation {

1213 pname = "reflex";

1314 version = "0.5.0";

@@ -20,7 +21,7 @@ mkDerivation {

2021 transformers-compat prim-uniq

2122 base bifunctors containers deepseq dependent-map dependent-sum

2223 mtl ref-tf split transformers data-default

23− random time unbounded-delays

24+ random time unbounded-delays generics-sop

2425 ] ++ (if !useTemplateHaskell then [] else [

2526 haskell-src-exts haskell-src-meta

2627 ]);

reflex.cabal+19−1

@@ -59,6 +59,7 @@ library

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

6060 dependent-map >= 0.2.4 && < 0.3,

6161 exception-transformers == 0.4.*,

62+ generics-sop >= 0.2.4.0,

6263 lens >= 4.7 && < 5,

6364 monad-control >= 1.0.1 && < 1.1,

6465 mtl >= 2.1 && < 2.3,

@@ -84,12 +85,15 @@ library

8485 Data.WeakBag,

8586 Data.FastWeakBag,

8687 Data.FastMutableIntMap,

88+ Generics.SOP.DMapUtilities,

89+ Generics.SOP.Distribute,

8790 Reflex,

8891 Reflex.Class,

8992 Reflex.Collection,

9093 Reflex.EventWriter,

9194 Reflex.Dynamic,

9295 Reflex.Dynamic.Uniq,

96+ Reflex.Dynamic.CollectDynGeneric,

9397 Reflex.DynamicWriter,

9498 Reflex.FastWeak,

9599 Reflex.FunctorMaybe,

@@ -120,7 +124,7 @@ library

120124 Reflex.Widget.Basic,

121125 Reflex.Workflow

122126

123− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively -ddump-simpl -ddump-to-file -dsuppress-coercions -dsuppress-idinfo

127+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively

124128 ghc-prof-options: -fprof-auto

125129

126130 if flag(specialize-to-spidertimeline-global)

@@ -168,6 +172,8 @@ test-suite semantics

168172 main-is: semantics.hs

169173 hs-source-dirs: test

170174 ghc-options: -O2 -Wall -rtsopts

175+ if flag(use-template-haskell)

176+ cpp-options: -DUSE_TEMPLATE_HASKELL

171177 build-depends:

172178 base,

173179 bifunctors,

@@ -275,6 +281,18 @@ test-suite rootCleanup

275281 build-depends: base

276282 , reflex

277283

284+test-suite mkDyn

285+ type: exitcode-stdio-1.0

286+ main-is: MkDyn.hs

287+ hs-source-dirs: test

288+ if !flag(use-template-haskell)

289+ buildable: False

290+ build-depends: base

291+ , reflex

292+ , deepseq

293+ , mtl

294+ , containers

295+

278296benchmark spider-bench

279297 type: exitcode-stdio-1.0

280298 hs-source-dirs: bench

src/Generics/SOP/DMapUtilities.hsnew file+184

@@ -0,0 +1,184 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE ExplicitNamespaces #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE KindSignatures #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

13+{-|

14+Module : Generics.SOP.DMapUtilities

15+Description : Utilities for converting between the NS/NP types of generics-sop and Dependent Maps.

16+-}

17+

18+module Generics.SOP.DMapUtilities

19+ (

20+ -- * Type Functions

21+ FunctorWrapTypeList

22+ , FunctorWrapTypeListOfLists

23+

24+ -- * Types

25+ , TypeListTag

26+

27+ -- * Conversions

28+ -- ** 'NP' \<-\> 'DM.DMap'

29+ , npToDMap

30+ , dMapToNP

31+ -- ** 'NS' \<-\> 'DSum'

32+ , nsToDSum

33+ , dSumToNS

34+

35+ -- * Functor wrapping/unwrapping utilities for 'NP'

36+ , npUnCompose

37+ , nsOfnpUnCompose

38+ , npReCompose

39+ , nsOfnpReCompose

40+

41+ -- * Utilities

42+ , npSequenceViaDMap

43+

44+ -- * Proofs

45+ , functorWrappedSListIsSList

46+ )where

47+

48+import Generics.SOP ((:.:) (Comp), K (..), NP (..), NS (..), Proxy (..), SList (..), SListI (..), SListI2, fn,

49+ hcollapse, hmap, unComp)

50+import Generics.SOP.Dict (Dict (Dict), withDict)

51+import Generics.SOP.NP (sequence'_NP)

52+import Generics.SOP.NS (ap_NS)

53+

54+import qualified Data.Dependent.Map as DM

55+import Data.Dependent.Sum (DSum ((:=>)))

56+import qualified Data.Dependent.Sum as DS

57+

58+import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))

59+

60+import Data.Functor.Identity (Identity (runIdentity))

61+

62+-- |A Tag type for making a 'DM.DMap' keyed by a type-level list

63+data TypeListTag (xs :: [k]) (x :: k) where -- x is in xs

64+ TLHead :: TypeListTag (x ': xs) x -- x begins xs

65+ TLTail :: TypeListTag xs x -> TypeListTag (y ': xs) x -- given that x is in xs, x is also in (y ': xs)

66+

67+instance GEq (TypeListTag xs) where

68+ geq TLHead TLHead = Just Refl

69+ geq (TLTail x) (TLTail y) = geq x y

70+ geq _ _ = Nothing

71+

72+instance GCompare (TypeListTag xs) where

73+ gcompare TLHead TLHead = GEQ

74+ gcompare TLHead (TLTail _) = GLT

75+ gcompare (TLTail _) TLHead = GGT

76+ gcompare (TLTail x) (TLTail y) = gcompare x y

77+

78+-- |Convert an 'NP' indexed by typelist xs into a 'DM.DMap' indexed by 'TypeListTag' xs

79+npToDMap :: NP f xs -> DM.DMap (TypeListTag xs) f

80+npToDMap Nil = DM.empty

81+npToDMap (fx :* npTail) = DM.insert TLHead fx $ DM.mapKeysMonotonic TLTail $ npToDMap npTail

82+

83+-- |Convert a 'DM.DMap' indexed by 'TypeListTag' xs to an 'NP'

84+-- |NB: This can fail since there is no guarantee that the 'DM.DMap' has entries for every tag. Hence it returns a 'Maybe'

85+dMapToNP :: forall xs f. SListI xs => DM.DMap (TypeListTag xs) f -> Maybe (NP f xs)

86+dMapToNP dm = sequence'_NP $ hmap (Comp . flip DM.lookup dm) makeTypeListTagNP

87+

88+-- |Convert a 'NS' indexed by a typelist xs to a 'DS.DSum' indexed by 'TypeListTag' xs

89+nsToDSum :: SListI xs => NS f xs -> DS.DSum (TypeListTag xs) f

90+nsToDSum = hcollapse . ap_NS (hmap (\tag -> (fn $ \val -> K (tag :=> val))) makeTypeListTagNP)

91+{- let nsFToNSDSum::SListI xs=>NS f xs -> NS (K (DS.DSum (TypeListTag xs) f)) xs

92+ nsFToNSDSum ns' = ap_NS (tagsToFs makeTypeListTagNP) ns'

93+ tagsToFs::SListI xs=>NP (TypeListTag xs) xs -> NP (f -.-> K (DS.DSum (TypeListTag xs) f)) xs

94+ tagsToFs = hmap (\tag -> (Fn $ \val -> K (tag :=> val)))

95+ in hcollapse . nsFToNSDSum

96+-}

97+

98+-- |Convert a 'DS.DSum' indexed by 'TypeListTag' xs into a 'NS' indexed by xs

99+dSumToNS :: SListI xs => DS.DSum (TypeListTag xs) f -> NS f xs

100+dSumToNS (tag :=> fa) = go tag fa

101+ where

102+ go::TypeListTag ys y -> f y -> NS f ys

103+ go TLHead fy = Z fy

104+ go (TLTail nextTag) fy = S $ go nextTag fy

105+

106+-- | Produce an NP of TypeListTags matching the type-list of the NP

107+makeTypeListTagNP :: SListI xs => NP (TypeListTag xs) xs

108+makeTypeListTagNP = go sList

109+ where

110+ go :: forall ys. SListI ys => SList ys -> NP (TypeListTag ys) ys

111+ go SNil = Nil

112+ go SCons = TLHead :* hmap TLTail (go sList)

113+

114+-- these are here to allow moving functors in and out of typelists

115+type family FunctorWrapTypeList (f :: * -> *) (xs :: [*]) :: [*] where

116+ FunctorWrapTypeList f '[] = '[]

117+ FunctorWrapTypeList f (x ': xs) = f x ': FunctorWrapTypeList f xs

118+

119+type family FunctorWrapTypeListOfLists (f :: * -> *) (xss :: [[*]]) :: [[*]] where

120+ FunctorWrapTypeListOfLists f '[] = '[]

121+ FunctorWrapTypeListOfLists f (xs ': xsTail) = FunctorWrapTypeList f xs ': FunctorWrapTypeListOfLists f xsTail

122+

123+-- | Transform a type-list indexed product of composed functorial values into a type-list indexed product of functorial values where the inner part of the functor

124+-- composition has been moved to the type-list. The values in the product remain the same (up to types representing composition of the functors). E.g.,

125+--

126+-- > (f :.: g) 2 :* (f :.: g) 3.0 :* 'Nil :: NP (f :.: g) '[Int,Double] -> f (g 2) :* f (g 3.0) :* 'Nil :: NP f '[g Int, g Double]

127+npUnCompose :: forall f g xs. SListI xs => NP (f :.: g) xs -> NP f (FunctorWrapTypeList g xs)

128+npUnCompose = go

129+ where

130+ go :: NP (f :.: g) ys -> NP f (FunctorWrapTypeList g ys)

131+ go Nil = Nil

132+ go (fgx :* npTail) = unComp fgx :* go npTail

133+

134+-- | UnCompose all of the 'NP's in an "NS (NP f) xss".

135+nsOfnpUnCompose :: forall f g xss. (SListI xss, SListI2 xss) => NS (NP (f :.: g)) xss -> NS (NP f) (FunctorWrapTypeListOfLists g xss)

136+nsOfnpUnCompose = go sList where

137+ go :: forall yss. (SListI yss, SListI2 yss) => SList yss -> NS (NP (f :.: g)) yss -> NS (NP f) (FunctorWrapTypeListOfLists g yss)

138+ go SNil _ = error "An NS cannot be empty"

139+ go SCons (Z np) = Z (npUnCompose np)

140+ go SCons (S ns') = S (go sList ns')

141+

142+-- | The inverse of 'npUnCompose'. Given a type-list indexed product where all the types in the list are applications of the same functor,

143+-- remove that functor from all the types in the list and put it in the functor parameter of the 'NP'. The values in the product itself remain the same up

144+-- to types representing composition of the functors.

145+npReCompose :: forall f g xs. SListI xs => NP f (FunctorWrapTypeList g xs) -> NP (f :.: g) xs

146+npReCompose = go sList

147+ where

148+ go :: forall ys. SListI ys => SList ys -> NP f (FunctorWrapTypeList g ys) -> NP (f :.: g) ys

149+ go SNil Nil = Nil

150+ go SCons (fgx :* npTail) = Comp fgx :* go sList npTail

151+

152+-- | ReCompose all the 'NP's in an "NS (NP f) xss".

153+nsOfnpReCompose :: forall f g xss. (SListI xss, SListI2 xss) => NS (NP f) (FunctorWrapTypeListOfLists g xss) -> NS (NP (f :.: g)) xss

154+nsOfnpReCompose = go sList

155+ where

156+ go :: forall yss. (SListI2 yss, SListI yss) => SList yss -> NS (NP f) (FunctorWrapTypeListOfLists g yss) -> NS (NP (f :.: g)) yss

157+ go SNil _ = error "NS must be non-empty." -- this shouldn't happen since an NS can't be empty

158+ go SCons (Z np) = Z $ npReCompose np

159+ go SCons (S nsTail) = S $ go sList nsTail

160+

161+-- | Prove that "SListI xs=>(FunctorWrapTypeList f xs)" is also an instance of SListI

162+functorWrappedSListIsSList :: forall f xs. SListI xs => Proxy f -> SList xs -> Dict SListI (FunctorWrapTypeList f xs)

163+functorWrappedSListIsSList _ SNil = Dict

164+functorWrappedSListIsSList pf SCons = goCons (sList :: SList xs)

165+ where

166+ goCons :: forall y ys. SList (y ': ys) -> Dict SListI (FunctorWrapTypeList f (y ': ys))

167+ goCons SCons =

168+ let dict = functorWrappedSListIsSList pf $ (sList :: SList ys)

169+ in withDict dict Dict

170+

171+-- | sequence (in the sense of 'Data.Traversable.sequenceA') a functor f inside an 'NP'

172+-- using a function defined over a 'DM.DMap' indexed by the same type-level-list.

173+-- This is useful in cases where an efficient general solution exists for DMaps.

174+-- This can be done more simply for Applicative f but the efficiency will depend on

175+-- the particular functor and given function over 'DM.DMap'.

176+npSequenceViaDMap :: forall k (f :: * -> *) (g :: * -> *) (xs :: [*]). (Functor f, SListI xs, DM.GCompare k

177+ , k ~ TypeListTag (FunctorWrapTypeList g xs))

178+ =>(DM.DMap k f -> f (DM.DMap k Identity))->NP (f :.: g) xs -> f (NP g xs)

179+npSequenceViaDMap sequenceDMap =

180+ withDict (functorWrappedSListIsSList (Proxy :: Proxy g) (sList :: SList xs)) $

181+ fmap (hmap (runIdentity . unComp) . npReCompose . (\(Just x) -> x) . dMapToNP) . sequenceDMap . npToDMap . npUnCompose

182+-- NB: The (\(Just x)->x) in there is safe!

183+-- dMapToNP has to return Maybe NP since the DMap could be incomplete.

184+-- But since we built this DMap from an NP, we know it's complete and dMapToNp will return a Just.

src/Generics/SOP/Distribute.hsnew file+120

@@ -0,0 +1,120 @@

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE KindSignatures #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE PolyKinds #-}

8+{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeOperators #-}

11+module Generics.SOP.Distribute

12+ (

13+ expand

14+ , expandA

15+ , WrappedProjection

16+ , wrappedProjections

17+ , shiftWrappedProjection

18+ , WrappedInjection

19+ , wrappedInjections

20+ , shiftWrappedInjection

21+ , distributeNP

22+ , distributeI_NP

23+ , functorToNP

24+ , reAssociateNP

25+ , distributeToFields

26+ , reconstructA

27+ , functionPOPFromClass

28+ , Dict

29+ ) where

30+

31+import Generics.SOP hiding (Compose)

32+import Generics.SOP.Dict (Dict, withDict)

33+

34+-- | Turn a sum into a product with Maybes

35+expand :: forall (f :: [k] -> *) xs. (SListI xs) => NS f xs -> NP (Maybe :.: f) xs

36+expand ns = go sList (Just ns) where

37+ go :: forall ys.SListI ys => SList ys -> Maybe (NS f ys) -> NP (Maybe :.: f) ys

38+ go SNil _ = Nil

39+ go SCons mNS = case mNS of

40+ Nothing -> Comp Nothing :* go sList Nothing -- after Z

41+ Just ms -> case ms of

42+ Z fx -> Comp (Just fx) :* go sList Nothing -- at Z

43+ S ms' -> Comp Nothing :* go sList (Just ms') -- before Z

44+

45+-- | expand applied to a generics-sop generic type

46+expandA :: Generic a => a -> NP (Maybe :.: NP I) (Code a)

47+expandA = expand . unSOP . from

48+

49+-- | The type of projections from functor-wrapped values

50+type WrappedProjection (g :: * -> *) (f :: k -> *) (xs :: [k]) = K (g (NP f xs)) -.-> g :.: f

51+

52+-- | Create wrapped projections for a specific typelist xs

53+wrappedProjections :: forall xs g f. (Functor g,SListI xs) => NP (WrappedProjection g f xs) xs

54+wrappedProjections = case sList :: SList xs of

55+ SNil -> Nil

56+ SCons -> fn (Comp . fmap hd . unK) :* hliftA shiftWrappedProjection wrappedProjections

57+

58+-- | Utility for creating the product of WrappedProjections

59+shiftWrappedProjection :: Functor g => WrappedProjection g f xs a -> WrappedProjection g f (x ': xs) a

60+shiftWrappedProjection (Fn f) = Fn $ f . K . fmap tl . unK

61+

62+type WrappedInjection (g :: * -> *) (f :: k -> *) (xs :: [k]) = g :.: f -.-> K (g (NS f xs))

63+

64+wrappedInjections :: forall xs g f. (Functor g, SListI xs) => NP (WrappedInjection g f xs) xs

65+wrappedInjections = case sList :: SList xs of

66+ SNil -> Nil

67+ SCons -> fn (K . fmap Z . unComp) :* hliftA shiftWrappedInjection wrappedInjections

68+

69+shiftWrappedInjection :: Functor g => WrappedInjection g f xs a -> WrappedInjection g f (x ': xs) a

70+shiftWrappedInjection (Fn f) = Fn $ K . fmap S . unK . f

71+

72+-- | distribute a functor h from outside a product into each field in the product.

73+--

74+-- NB: For applicative h, this is an inverse of hsequence. If h is not applicative, then this is not invertible.

75+distributeNP :: (Functor h, SListI xs) => h (NP g xs) -> NP (h :.: g) xs

76+distributeNP x = hap wrappedProjections (hpure $ K x)

77+

78+-- | A special case of distribute when the product is parameterized over the identity

79+distributeI_NP :: (Functor h, SListI xs) => h (NP I xs) -> NP h xs

80+distributeI_NP = hmap (fmap unI . unComp) . distributeNP

81+

82+-- | Turn a functor wrapped value into a product of functor wrapped Maybes of products

83+-- with the outer product over constructors and the inner over fields

84+functorToNP :: forall g a.(Functor g,Generic a)=>g a -> NP (g :.: (Maybe :.: NP I)) (Code a)

85+functorToNP ga = hap wrappedProjections (hpure $ K (expandA <$> ga))

86+

87+-- | utility for manipulating functors in NPs

88+reAssociate :: Functor g => (g :.: (f :.: h)) a -> ((g :.: f) :.: h) a

89+reAssociate = Comp . Comp . fmap unComp . unComp

90+

91+-- | utility for manipulating functors in NPs

92+reAssociateNP :: (Functor g, SListI xss) => NP (g :.: (f :.: h)) xss->NP ((g :.: f) :.: h) xss

93+reAssociateNP = hmap reAssociate

94+

95+-- | Apply dsitributeI_NP to all constructors of an NS of an NP

96+distributeToFields :: (Functor g, SListI2 xss) => NP ((g :.: Maybe) :.: NP I) xss -> POP (g :.: Maybe) xss

97+distributeToFields =

98+ let proxyC = Proxy :: Proxy SListI

99+ in POP . hcliftA proxyC (distributeI_NP . unComp)

100+

101+-- | reconstruct the per constructor, functor wrapped value from an NP of (Maybe :.: NP)

102+reconstructA :: (Functor h, Generic a) => NP (h :.: NP I) (Code a) -> NP (K (h a)) (Code a)

103+reconstructA = hliftA (K . fmap (to . SOP) . unK) . hap wrappedInjections

104+

105+-- | Utility for turning a constraint into a POP (an NP of NP) of natural transformations at a given type.

106+functionPOPFromClass :: forall c f g xss. SListI2 xss

107+ => Dict (All2 c) xss

108+ -> (forall a. c a => f a -> g a)

109+ -> POP (f -.-> g) xss

110+functionPOPFromClass d f = withDict d $ hcpure (Proxy :: Proxy c) $ Fn f

111+

112+{-

113+functionPOPFromClass'::forall c f g xss.(All2 c xss, SListI2 xss)=>(forall a.c a=>f a -> g a)->POP (f -.-> g) xss

114+functionPOPFromClass' fn =

115+ let dict :: Dict (All2 c) xss

116+ dict = all_POP hdicts

117+ in withDict dict $ hcpure (Proxy :: Proxy c) $ Fn fn

118+-}

119+

120+

src/Reflex/Dynamic.hs+53−12

@@ -38,6 +38,7 @@ module Reflex.Dynamic

3838 , maybeDyn

3939 , eitherDyn

4040 , factorDyn

41+ , factorDynGeneric

4142 , scanDyn

4243 , scanDynMaybe

4344 , holdUniqDyn

@@ -57,15 +58,6 @@ module Reflex.Dynamic

5758 , Demux

5859 , demux

5960 , demuxed

60− -- Things that probably aren't very useful:

61− , HList (..)

62− , FHList (..)

63− , collectDynPure

64− , RebuildSortedHList (..)

65− , IsHList (..)

66− , AllAreFunctors (..)

67− , HListPtr (..)

68− , distributeFHListOverDynPure

6961 -- Unsafe

7062 , unsafeDynamic

7163 -- * Deprecated functions

@@ -87,9 +79,17 @@ module Reflex.Dynamic

8779 , tagDyn

8880 , uniqDyn

8981 , uniqDynBy

82+ -- Things that probably aren't very useful, and are also deprecated

83+ , HList (..)

84+ , FHList (..)

85+ , collectDynPure

86+ , RebuildSortedHList (..)

87+ , IsHList (..)

88+ , AllAreFunctors (..)

89+ , HListPtr (..)

90+ , distributeFHListOverDynPure

9091 ) where

9192

92−import Data.Functor.Compose

9393import Data.Functor.Misc

9494import Reflex.Class

9595

@@ -101,11 +101,15 @@ import Data.Align

101101import Data.Dependent.Map (DMap)

102102import qualified Data.Dependent.Map as DMap

103103import Data.Dependent.Sum (DSum (..))

104+import Data.Functor.Compose (Compose (Compose), getCompose)

104105import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))

105106import Data.Map (Map)

106−import Data.Maybe

107+import Data.Maybe (isJust)

107108import Data.Monoid

108109import Data.These

110+import Generics.SOP ((:.:) (Comp), Code, Generic, I (I), Proxy (Proxy), SListI, SOP (SOP), from, hcmap, hmap, to, unSOP)

111+import Generics.SOP.Distribute (distributeI_NP)

112+import Generics.SOP.DMapUtilities (FunctorWrapTypeListOfLists, dSumToNS, nsOfnpUnCompose, nsToDSum)

109113

110114import Debug.Trace

111115

@@ -329,6 +333,29 @@ factorDyn d = do

329333 o0 <- getInitial --TODO: Figure out how to get this to run inside something like the first argument to buildDynamic

330334 holdDyn o0 update

331335

336+-- | Use factorDyn and generics-sop to turn a Dynamic of a type into a factored

337+-- Dynamic of a type with Dynamic fields. For example:

338+--

339+-- > maybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe (Dynamic t a)))

340+-- > maybeDyn = factorDynGeneric

341+--

342+-- > eitherDyn :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Either a b) -> m (Dynamic t (Either (Dynamic t a) (Dynamic t b)))

343+-- > eitherDyn = factorDynGeneric

344+

345+factorDynGeneric :: forall t m a b. (Reflex t, MonadFix m, MonadHold t m

346+ , Generic a, Generic b

347+ , (Code b) ~ FunctorWrapTypeListOfLists (Dynamic t) (Code a))

348+ => Dynamic t a -> m (Dynamic t b)

349+factorDynGeneric da = do

350+ let dSumDyn = nsToDSum . unSOP . from <$> da -- Dynamic t (DSum (TypeListTag (Code a)) (NP I xs))

351+ dSumDyn' <- factorDyn dSumDyn -- Dynamic t (DSum (TypeListTag (Code a)) (NP I))

352+ let nsnpDyn = dSumToNS <$> dSumDyn' -- Dynamic t (NS (Compose (Dynamic t) (NP I)) (Code a))

353+ sListIC = Proxy :: Proxy SListI

354+ nsnpDyn' = hcmap sListIC (hmap (Comp. I) . distributeI_NP . getCompose) <$> nsnpDyn -- Dynamic t (NS (NP (I :.: Dynamic t)) (Code a))

355+ nsnpDyn'' = nsOfnpUnCompose <$> nsnpDyn' -- Dynamic t (NS (NP I) (Code b))

356+ result = to . SOP <$> nsnpDyn''

357+ return result

358+

332359--------------------------------------------------------------------------------

333360-- Demux

334361--------------------------------------------------------------------------------

@@ -366,15 +393,22 @@ demuxed d k =

366393 let e = select (demuxSelector d) (Const2 k)

367394 in unsafeBuildDynamic (fmap (==k) $ sample $ demuxValue d) e

368395

396+

369397--------------------------------------------------------------------------------

370398-- collectDyn

371399--------------------------------------------------------------------------------

372400

373−--TODO: This whole section is badly in need of cleanup

401+-- | This is now deprecated in favor of types from the generics-sop library and

402+-- functions provided in Reflex.Dynamic.CollectDynGeneric

403+-- The generics-sop 'NP' product type takes the place of FHList and HList.

404+-- Utilities to manipulate the NP types (shifting functors from the type into and out of the type-list

405+-- and convert from NP to DMap and DMap to NP are all in Generics.SOP.DMapUtilities

406+-- Equivalent "distribute" and "collect" functions are now in Reflex.Dynamic.CollectDynGeneric

374407

375408-- | A heterogeneous list whose type and length are fixed statically. This is

376409-- reproduced from the 'HList' package due to integration issues, and because

377410-- very little other functionality from that library is needed.

411+{-# DEPRECATED HList, HRevApp, hRevApp, hReverse, hBuild, HBuild' "This interface for type-level lists is being deprecated in favor of the 'NP' type from generics-sop" #-}

378412data HList (l::[*]) where

379413 HNil :: HList '[]

380414 HCons :: e -> HList l -> HList (e ': l)

@@ -407,6 +441,7 @@ instance HBuild' (a ': l) r

407441 hBuild' l x = hBuild' (HCons x l)

408442

409443-- | Like 'HList', but with a functor wrapping each element.

444+{-# DEPRECATED FHList,RebuildSortedHList "This interface for type-level lists is being deprecated in favor of the 'NP' type from generics-sop" #-}

410445data FHList f l where

411446 FHNil :: FHList f '[]

412447 FHCons :: f e -> FHList f l -> FHList f (e ': l)

@@ -433,6 +468,7 @@ instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dma

433468 HTailPtr a `gcompare` HTailPtr b = a `gcompare` b

434469

435470-- | A typed index into a typed heterogeneous list.

471+{-# DEPRECATED HListPtr "Use 'Generics.SOP.DMapUtiltiies.TypeListTag' instead" #-}

436472data HListPtr l a where

437473 HHeadPtr :: HListPtr (h ': t) h

438474 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a

@@ -440,6 +476,7 @@ data HListPtr l a where

440476deriving instance Eq (HListPtr l a)

441477deriving instance Ord (HListPtr l a)

442478

479+{-# DEPRECATED fhlistToDMap "Use generics-sop 'NP' for your functor wrapped type-list and then 'Generics.SOP.DMapUtilities.npToDMap'" #-}

443480fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f

444481fhlistToDMap = DMap.fromList . go

445482 where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]

@@ -469,17 +506,20 @@ instance RebuildSortedHList t => RebuildSortedHList (h ': t) where

469506 ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t

470507 _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"

471508

509+{-# DEPRECATED dmapToHList "Use generics-sop 'NP' for your functor wrapped type-list and then 'Generics.SOP.DMapUtilities.dMapToNP'" #-}

472510dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l

473511dmapToHList = rebuildSortedHList . DMap.toList

474512

475513-- | Collect a hetereogeneous list whose elements are all 'Dynamic's into a

476514-- single 'Dynamic' whose value represents the current values of all of the

477515-- input 'Dynamic's.

516+{-# DEPRECATED distributeFHListOverDynPure "Use the generics-sop 'NP' type for functor-wrapped type-lists and then 'Reflex.Dynamic.CollectDynGeneric.collectDynNP' " #-}

478517distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l)

479518distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l

480519

481520-- | Indicates that all elements in a type-level list are applications of the

482521-- same functor.

522+{-# DEPRECATED AllAreFunctors "This functionality is provided for generics-sop 'NP' via 'Generics.SOP.DMapUtilties.npUnCompose' and 'Generics.SOP.DMapUtilities.npReCompose'" #-}

483523class AllAreFunctors (f :: a -> *) (l :: [a]) where

484524 type FunctorList f l :: [*]

485525 toFHList :: HList (FunctorList f l) -> FHList f l

@@ -506,6 +546,7 @@ instance AllAreFunctors f t => AllAreFunctors f (h ': t) where

506546-- | Convert a datastructure whose constituent parts are all 'Dynamic's into a

507547-- single 'Dynamic' whose value represents all the current values of the input's

508548-- consitutent 'Dynamic's.

549+{-# DEPRECATED collectDynPure "Use 'Reflex.Dynamic.CollectDynGeneric.collectDynGeneric' instead." #-}

509550collectDynPure :: ( RebuildSortedHList (HListElems b)

510551 , IsHList a, IsHList b

511552 , AllAreFunctors (Dynamic t) (HListElems b)

src/Reflex/Dynamic/CollectDynGeneric.hsnew file+64

@@ -0,0 +1,64 @@

1+{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ExplicitNamespaces #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

13+{-|

14+Module: Reflex.Dynamic.CollectDynGeneric

15+Description: Generic (generics-sop) implementation of CollectDynPure and distributeFHListOverDynPure

16+-}

17+module Reflex.Dynamic.CollectDynGeneric

18+ (

19+ collectDynGeneric

20+ , collectDynNP

21+ , distributeNPOverDyn

22+ ) where

23+

24+import Generics.SOP ((:.:) (Comp), Code, Generic, I (I), NP, NS, Proxy (..), SListI, SListI2, SOP (..), from,

25+ hcliftA, hliftA, hsequence', to, unComp, unI, unSOP)

26+

27+import Generics.SOP.DMapUtilities (FunctorWrapTypeList, FunctorWrapTypeListOfLists, npReCompose,

28+ npSequenceViaDMap, nsOfnpReCompose)

29+

30+import Reflex.Class (Reflex)

31+import Reflex.Dynamic (Dynamic, distributeDMapOverDynPure)

32+

33+-- | Take a type-list indexed product of dynamics and produce a dynamic of a type-list-indexed product of values (wrapped by an Identity functor, 'I').

34+collectDynNP :: (Reflex t, SListI xs) => NP (Dynamic t) xs -> Dynamic t (NP I xs)

35+collectDynNP = npSequenceViaDMap distributeDMapOverDynPure . hliftA (Comp . fmap I)

36+

37+-- | Given a pair of types a and b, each of which is an instance of 'Generics.SOP.Generic' (which is easily derived from GHC 'GHC.Generics.Generic')

38+-- and where a is "like" b except each field of each constructor is a Dynamic,

39+-- convert the former into a Dynamic of the latter. E.g.,

40+--

41+-- > (Dynamic t x, Dynamic t y) -> Dynamic t (x,y)

42+-- > Either (Dynamic t x) (Dynamic t y) -> Dynamic t (Either x y)

43+collectDynGeneric :: (Reflex t, Generic a, Generic b, (Code a) ~ FunctorWrapTypeListOfLists (Dynamic t) (Code b)) => a -> Dynamic t b

44+collectDynGeneric = fmap (to . SOP) . hsequence' . collectDynNSNP . aToNSNPI

45+

46+-- | A variation on 'collectDynNP' which more closely mirrors the structure of (deprecated) 'Reflex.Dynamic.distributeFHlistOverDynPure'

47+distributeNPOverDyn :: (Reflex t, SListI xs) => NP I (FunctorWrapTypeList (Dynamic t) xs) -> Dynamic t (NP I xs)

48+distributeNPOverDyn = collectDynNP . hliftA (unI . unComp) . npReCompose

49+

50+-- | Utility to help simplify collectDynGeneric: Take a generic type, a, which is Dynamic in every field and make an NS of an NP

51+aToNSNPI :: (Generic a, Code a ~ FunctorWrapTypeListOfLists (Dynamic t) xss, SListI2 xss) => a -> NS (NP (I :.: Dynamic t)) xss

52+aToNSNPI = nsOfnpReCompose . unSOP . from

53+

54+-- | Utility to help simplify collectDynGeneric: Take an NS of an NP of Dynamic fields and collect (or sequence)

55+-- the Dynamics from fields to constructors

56+collectDynNSNP :: (Reflex t, SListI2 xss) => NS (NP (I :.: Dynamic t)) xss -> NS (Dynamic t :.: NP I) xss

57+collectDynNSNP =

58+ let slistIC = Proxy :: Proxy SListI

59+ in hcliftA slistIC $ Comp . collectDynNP . hliftA (unI . unComp)

60+

61+

62+

63+

64+

src/Reflex/Dynamic/TH.hs+6−4

@@ -18,7 +18,8 @@ module Reflex.Dynamic.TH

1818 , mkDyn

1919 ) where

2020

21−import Reflex.Dynamic

21+import Generics.SOP (I (..), NP (..))

22+import Reflex.Dynamic.CollectDynGeneric (collectDynNP)

2223

2324import Control.Monad.State

2425import Data.Data

@@ -47,9 +48,10 @@ qDynPure qe = do

4748 _ -> gmapM f d

4849 (e', exprsReversed) <- runStateT (gmapM f e) []

4950 let exprs = reverse exprsReversed

50− arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs

51− param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs

52− [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |]

51+ arg = foldr (\a b -> ConE '(:*) `AppE` a `AppE` b) (ConE 'Nil) $ map snd exprs

52+ param = foldr (\a b -> ConP '(:*) [ConP 'I [VarP a], b]) (ConP 'Nil []) $ map fst exprs

53+ [| $(return $ LamE [param] e') <$> collectDynNP $(return arg) |]

54+

5355

5456-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a

5557-- 'qDyn' quotation.

test/MkDyn.hsnew file+38

@@ -0,0 +1,38 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE GADTs #-}

3+{-# LANGUAGE QuasiQuotes #-}

4+module Main where

6+import Data.IntMap

7+import Reflex

8+import Reflex.Dynamic.TH

9+import Reflex.Plan.Pure

10+import Reflex.TestPlan

11+import System.Exit

12+

13+main::IO ()

14+main = do

15+ let setup = do

16+ pEv1 <- planList [1.0,2.0,3.0]

17+ pEv2 <- planList [-1.0,-2.0,-3.0]

18+ dyn1 <- holdDyn 0 pEv1

19+ dyn2 <- holdDyn 0 pEv2

20+ return (dyn1, dyn2)

21+ resMkDyn :: IntMap (Maybe Double)

22+ resMkDyn = testEvent $ runPure $ do

23+ (dyn1, dyn2) <- setup

24+ let dynFromMkDyn = [mkDynPure|$dyn1 + $dyn2|]

25+ return $ updated dynFromMkDyn

26+ resZipDyn :: IntMap (Maybe Double)

27+ resZipDyn = testEvent $ runPure $ do

28+ (dyn1,dyn2) <- setup

29+ let dynFromZipDyn = zipDynWith (+) dyn1 dyn2

30+ return $ updated dynFromZipDyn

31+ testPassed = resMkDyn == resZipDyn

32+ putStrLn $ "MkDynPure: " ++ show resMkDyn

33+ putStrLn $ "zipDynWith: " ++ show resZipDyn

34+ putStr "MkDyn: "

35+ if testPassed then putStrLn "Succeeded" else putStrLn "Failed"

36+ exitWith $ if testPassed then ExitSuccess else ExitFailure 1

37+

38+

test/Reflex/Test/TH.hsnew file+26

@@ -0,0 +1,26 @@

1+{-# LANGUAGE GADTs #-}

2+{-# LANGUAGE MultiParamTypeClasses #-}

3+{-# LANGUAGE QuasiQuotes #-}

4+module Reflex.Test.TH (testCases) where

6+import Reflex

8+import Reflex.TestPlan

10+testCases :: [(String, TestCase)]

11+testCases =

12+ [

13+ testE "mkDynPure" $ do

14+ dyn1 <- holdDyn 0 =<< events1

15+ dyn2 <- holdDyn 0 =<< events2

16+ let dynResult = [mkDynPure|$dyn1 + $dyn2|]

17+ return $ updated dynResult

18+ ] where

19+

20+ events1, events2 :: TestPlan t m => m (Event t Int)

21+ events1 = plan [(1, 1), (11, 2), (21, 3), (31, 4), (41, 5)]

22+ events2 = plan [(5, 10), (15, 20), (25, 30), (35, 40), (45, 50)]

23+

24+

25+

26+

test/semantics.hs+7−2

@@ -1,10 +1,10 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE FlexibleContexts #-}

34{-# LANGUAGE FlexibleInstances #-}

45{-# LANGUAGE GADTs #-}

56{-# LANGUAGE MultiParamTypeClasses #-}

67{-# LANGUAGE RankNTypes #-}

7−

88module Main (main) where

1010import Reflex.Test

@@ -14,7 +14,9 @@ import Data.Functor

1414import Data.List

1515import qualified Reflex.Bench.Focused as Focused

1616import qualified Reflex.Test.Micro as Micro

17−

17+#ifdef USE_TEMPLATE_HASKELL

18+import qualified Reflex.Test.TH as TH

19+#endif

1820import System.Environment

1921import System.Exit

2022

@@ -38,6 +40,9 @@ main = do

3840 where

3941 allTests = concat

4042 [ makeGroup "micro" Micro.testCases

43+#ifdef USE_TEMPLATE_HASKELL

44+ , makeGroup "TH" TH.testCases

45+#endif

4146 , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40)

4247 , makeGroup "firing 1000" (Focused.firing 1000)

4348 , makeGroup "merge 100" (Focused.merging 100)