git.iko.soy/reflex
on c2c3f13 help sign in
90891e1
swap
1 ahead, 677 behind
.gitignore+1
since splitsnapshots
unifiedsplit
@@ -36,3 +36,4 @@ hsenv.log
36/ghci-tmp
36/ghci-tmp
37*.dump-*
37*.dump-*
38*.verbose-core2core
38*.verbose-core2core
39+.stack-work/*
default.nix+5−4
@@ -2,12 +2,13 @@
2, dependent-map, dependent-sum, exception-transformers
2, dependent-map, dependent-sum, exception-transformers
3, haskell-src-exts, haskell-src-meta, hlint, lens, MemoTrie
3, haskell-src-exts, haskell-src-meta, hlint, lens, MemoTrie
4, monad-control, mtl, primitive, random, ref-tf
4, monad-control, mtl, primitive, random, ref-tf
5−, semigroupoids , semigroups, split, stdenv, stm, syb
5+, semigroupoids, semigroups, split, stdenv, stm, syb
6−, template-haskell , these, time, transformers
6+, template-haskell, these, time, transformers
7, transformers-compat, unbounded-delays, prim-uniq
7, transformers-compat, unbounded-delays, prim-uniq
8−, data-default , filepath, directory, filemanip
8+, data-default, filepath, directory, filemanip, generics-sop
9, useTemplateHaskell ? true
9, useTemplateHaskell ? true
10}:
10}:
11+
11mkDerivation {
12mkDerivation {
12 pname = "reflex";
13 pname = "reflex";
13 version = "0.5.0";
14 version = "0.5.0";
@@ -20,7 +21,7 @@ mkDerivation {
20 transformers-compat prim-uniq
21 transformers-compat prim-uniq
21 base bifunctors containers deepseq dependent-map dependent-sum
22 base bifunctors containers deepseq dependent-map dependent-sum
22 mtl ref-tf split transformers data-default
23 mtl ref-tf split transformers data-default
23− random time unbounded-delays
24+ random time unbounded-delays generics-sop
24 ] ++ (if !useTemplateHaskell then [] else [
25 ] ++ (if !useTemplateHaskell then [] else [
25 haskell-src-exts haskell-src-meta
26 haskell-src-exts haskell-src-meta
26 ]);
27 ]);
reflex.cabal+19−1
@@ -59,6 +59,7 @@ library
59 data-default >= 0.5 && < 0.8,
59 data-default >= 0.5 && < 0.8,
60 dependent-map >= 0.2.4 && < 0.3,
60 dependent-map >= 0.2.4 && < 0.3,
61 exception-transformers == 0.4.*,
61 exception-transformers == 0.4.*,
62+ generics-sop >= 0.2.4.0,
62 lens >= 4.7 && < 5,
63 lens >= 4.7 && < 5,
63 monad-control >= 1.0.1 && < 1.1,
64 monad-control >= 1.0.1 && < 1.1,
64 mtl >= 2.1 && < 2.3,
65 mtl >= 2.1 && < 2.3,
@@ -84,12 +85,15 @@ library
84 Data.WeakBag,
85 Data.WeakBag,
85 Data.FastWeakBag,
86 Data.FastWeakBag,
86 Data.FastMutableIntMap,
87 Data.FastMutableIntMap,
88+ Generics.SOP.DMapUtilities,
89+ Generics.SOP.Distribute,
87 Reflex,
90 Reflex,
88 Reflex.Class,
91 Reflex.Class,
89 Reflex.Collection,
92 Reflex.Collection,
90 Reflex.EventWriter,
93 Reflex.EventWriter,
91 Reflex.Dynamic,
94 Reflex.Dynamic,
92 Reflex.Dynamic.Uniq,
95 Reflex.Dynamic.Uniq,
96+ Reflex.Dynamic.CollectDynGeneric,
93 Reflex.DynamicWriter,
97 Reflex.DynamicWriter,
94 Reflex.FastWeak,
98 Reflex.FastWeak,
95 Reflex.FunctorMaybe,
99 Reflex.FunctorMaybe,
@@ -120,7 +124,7 @@ library
120 Reflex.Widget.Basic,
124 Reflex.Widget.Basic,
121 Reflex.Workflow
125 Reflex.Workflow
122
126
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
124 ghc-prof-options: -fprof-auto
128 ghc-prof-options: -fprof-auto
125
129
126 if flag(specialize-to-spidertimeline-global)
130 if flag(specialize-to-spidertimeline-global)
@@ -168,6 +172,8 @@ test-suite semantics
168 main-is: semantics.hs
172 main-is: semantics.hs
169 hs-source-dirs: test
173 hs-source-dirs: test
170 ghc-options: -O2 -Wall -rtsopts
174 ghc-options: -O2 -Wall -rtsopts
175+ if flag(use-template-haskell)
176+ cpp-options: -DUSE_TEMPLATE_HASKELL
171 build-depends:
177 build-depends:
172 base,
178 base,
173 bifunctors,
179 bifunctors,
@@ -275,6 +281,18 @@ test-suite rootCleanup
275 build-depends: base
281 build-depends: base
276 , reflex
282 , reflex
277
283
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+
278benchmark spider-bench
296benchmark spider-bench
279 type: exitcode-stdio-1.0
297 type: exitcode-stdio-1.0
280 hs-source-dirs: bench
298 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
38 , maybeDyn
38 , maybeDyn
39 , eitherDyn
39 , eitherDyn
40 , factorDyn
40 , factorDyn
41+ , factorDynGeneric
41 , scanDyn
42 , scanDyn
42 , scanDynMaybe
43 , scanDynMaybe
43 , holdUniqDyn
44 , holdUniqDyn
@@ -57,15 +58,6 @@ module Reflex.Dynamic
57 , Demux
58 , Demux
58 , demux
59 , demux
59 , demuxed
60 , 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
69 -- Unsafe
61 -- Unsafe
70 , unsafeDynamic
62 , unsafeDynamic
71 -- * Deprecated functions
63 -- * Deprecated functions
@@ -87,9 +79,17 @@ module Reflex.Dynamic
87 , tagDyn
79 , tagDyn
88 , uniqDyn
80 , uniqDyn
89 , uniqDynBy
81 , 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
90 ) where
91 ) where
91
92
92−import Data.Functor.Compose
93import Data.Functor.Misc
93import Data.Functor.Misc
94import Reflex.Class
94import Reflex.Class
95
95
@@ -101,11 +101,15 @@ import Data.Align
101import Data.Dependent.Map (DMap)
101import Data.Dependent.Map (DMap)
102import qualified Data.Dependent.Map as DMap
102import qualified Data.Dependent.Map as DMap
103import Data.Dependent.Sum (DSum (..))
103import Data.Dependent.Sum (DSum (..))
104+import Data.Functor.Compose (Compose (Compose), getCompose)
104import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))
105import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))
105import Data.Map (Map)
106import Data.Map (Map)
106−import Data.Maybe
107+import Data.Maybe (isJust)
107import Data.Monoid
108import Data.Monoid
108import Data.These
109import 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)
109
113
110import Debug.Trace
114import Debug.Trace
111
115
@@ -329,6 +333,29 @@ factorDyn d = do
329 o0 <- getInitial --TODO: Figure out how to get this to run inside something like the first argument to buildDynamic
333 o0 <- getInitial --TODO: Figure out how to get this to run inside something like the first argument to buildDynamic
330 holdDyn o0 update
334 holdDyn o0 update
331
335
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+
332--------------------------------------------------------------------------------
359--------------------------------------------------------------------------------
333-- Demux
360-- Demux
334--------------------------------------------------------------------------------
361--------------------------------------------------------------------------------
@@ -366,15 +393,22 @@ demuxed d k =
366 let e = select (demuxSelector d) (Const2 k)
393 let e = select (demuxSelector d) (Const2 k)
367 in unsafeBuildDynamic (fmap (==k) $ sample $ demuxValue d) e
394 in unsafeBuildDynamic (fmap (==k) $ sample $ demuxValue d) e
368
395
396+
369--------------------------------------------------------------------------------
397--------------------------------------------------------------------------------
370-- collectDyn
398-- collectDyn
371--------------------------------------------------------------------------------
399--------------------------------------------------------------------------------
372
400
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
374
407
375-- | A heterogeneous list whose type and length are fixed statically. This is
408-- | A heterogeneous list whose type and length are fixed statically. This is
376-- reproduced from the 'HList' package due to integration issues, and because
409-- reproduced from the 'HList' package due to integration issues, and because
377-- very little other functionality from that library is needed.
410-- 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" #-}
378data HList (l::[*]) where
412data HList (l::[*]) where
379 HNil :: HList '[]
413 HNil :: HList '[]
380 HCons :: e -> HList l -> HList (e ': l)
414 HCons :: e -> HList l -> HList (e ': l)
@@ -407,6 +441,7 @@ instance HBuild' (a ': l) r
407 hBuild' l x = hBuild' (HCons x l)
441 hBuild' l x = hBuild' (HCons x l)
408
442
409-- | Like 'HList', but with a functor wrapping each element.
443-- | 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" #-}
410data FHList f l where
445data FHList f l where
411 FHNil :: FHList f '[]
446 FHNil :: FHList f '[]
412 FHCons :: f e -> FHList f l -> FHList f (e ': l)
447 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
433 HTailPtr a `gcompare` HTailPtr b = a `gcompare` b
468 HTailPtr a `gcompare` HTailPtr b = a `gcompare` b
434
469
435-- | A typed index into a typed heterogeneous list.
470-- | A typed index into a typed heterogeneous list.
471+{-# DEPRECATED HListPtr "Use 'Generics.SOP.DMapUtiltiies.TypeListTag' instead" #-}
436data HListPtr l a where
472data HListPtr l a where
437 HHeadPtr :: HListPtr (h ': t) h
473 HHeadPtr :: HListPtr (h ': t) h
438 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a
474 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a
@@ -440,6 +476,7 @@ data HListPtr l a where
440deriving instance Eq (HListPtr l a)
476deriving instance Eq (HListPtr l a)
441deriving instance Ord (HListPtr l a)
477deriving instance Ord (HListPtr l a)
442
478
479+{-# DEPRECATED fhlistToDMap "Use generics-sop 'NP' for your functor wrapped type-list and then 'Generics.SOP.DMapUtilities.npToDMap'" #-}
443fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f
480fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f
444fhlistToDMap = DMap.fromList . go
481fhlistToDMap = DMap.fromList . go
445 where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]
482 where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]
@@ -469,17 +506,20 @@ instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
469 ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
506 ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
470 _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"
507 _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"
471
508
509+{-# DEPRECATED dmapToHList "Use generics-sop 'NP' for your functor wrapped type-list and then 'Generics.SOP.DMapUtilities.dMapToNP'" #-}
472dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l
510dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l
473dmapToHList = rebuildSortedHList . DMap.toList
511dmapToHList = rebuildSortedHList . DMap.toList
474
512
475-- | Collect a hetereogeneous list whose elements are all 'Dynamic's into a
513-- | Collect a hetereogeneous list whose elements are all 'Dynamic's into a
476-- single 'Dynamic' whose value represents the current values of all of the
514-- single 'Dynamic' whose value represents the current values of all of the
477-- input 'Dynamic's.
515-- input 'Dynamic's.
516+{-# DEPRECATED distributeFHListOverDynPure "Use the generics-sop 'NP' type for functor-wrapped type-lists and then 'Reflex.Dynamic.CollectDynGeneric.collectDynNP' " #-}
478distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l)
517distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l)
479distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l
518distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l
480
519
481-- | Indicates that all elements in a type-level list are applications of the
520-- | Indicates that all elements in a type-level list are applications of the
482-- same functor.
521-- same functor.
522+{-# DEPRECATED AllAreFunctors "This functionality is provided for generics-sop 'NP' via 'Generics.SOP.DMapUtilties.npUnCompose' and 'Generics.SOP.DMapUtilities.npReCompose'" #-}
483class AllAreFunctors (f :: a -> *) (l :: [a]) where
523class AllAreFunctors (f :: a -> *) (l :: [a]) where
484 type FunctorList f l :: [*]
524 type FunctorList f l :: [*]
485 toFHList :: HList (FunctorList f l) -> FHList f l
525 toFHList :: HList (FunctorList f l) -> FHList f l
@@ -506,6 +546,7 @@ instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
506-- | Convert a datastructure whose constituent parts are all 'Dynamic's into a
546-- | Convert a datastructure whose constituent parts are all 'Dynamic's into a
507-- single 'Dynamic' whose value represents all the current values of the input's
547-- single 'Dynamic' whose value represents all the current values of the input's
508-- consitutent 'Dynamic's.
548-- consitutent 'Dynamic's.
549+{-# DEPRECATED collectDynPure "Use 'Reflex.Dynamic.CollectDynGeneric.collectDynGeneric' instead." #-}
509collectDynPure :: ( RebuildSortedHList (HListElems b)
550collectDynPure :: ( RebuildSortedHList (HListElems b)
510 , IsHList a, IsHList b
551 , IsHList a, IsHList b
511 , AllAreFunctors (Dynamic t) (HListElems b)
552 , 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
18 , mkDyn
18 , mkDyn
19 ) where
19 ) where
20
20
21−import Reflex.Dynamic
21+import Generics.SOP (I (..), NP (..))
22+import Reflex.Dynamic.CollectDynGeneric (collectDynNP)
22
23
23import Control.Monad.State
24import Control.Monad.State
24import Data.Data
25import Data.Data
@@ -47,9 +48,10 @@ qDynPure qe = do
47 _ -> gmapM f d
48 _ -> gmapM f d
48 (e', exprsReversed) <- runStateT (gmapM f e) []
49 (e', exprsReversed) <- runStateT (gmapM f e) []
49 let exprs = reverse exprsReversed
50 let exprs = reverse exprsReversed
50− arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs
51+ arg = foldr (\a b -> ConE '(:*) `AppE` a `AppE` b) (ConE 'Nil) $ map snd exprs
51− param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs
52+ param = foldr (\a b -> ConP '(:*) [ConP 'I [VarP a], b]) (ConP 'Nil []) $ map fst exprs
52− [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |]
53+ [| $(return $ LamE [param] e') <$> collectDynNP $(return arg) |]
54+
53
55
54-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a
56-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a
55-- 'qDyn' quotation.
57-- 'qDyn' quotation.
test/MkDyn.hsnew file+38
@@ -0,0 +1,38 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE QuasiQuotes #-}
4+module Main where
5+
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
5+
6+import Reflex
7+
8+import Reflex.TestPlan
9+
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 #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GADTs #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE RankNTypes #-}
7−
8module Main (main) where
8module Main (main) where
9
9
10import Reflex.Test
10import Reflex.Test
@@ -14,7 +14,9 @@ import Data.Functor
14import Data.List
14import Data.List
15import qualified Reflex.Bench.Focused as Focused
15import qualified Reflex.Bench.Focused as Focused
16import qualified Reflex.Test.Micro as Micro
16import qualified Reflex.Test.Micro as Micro
17−
17+#ifdef USE_TEMPLATE_HASKELL
18+import qualified Reflex.Test.TH as TH
19+#endif
18import System.Environment
20import System.Environment
19import System.Exit
21import System.Exit
20
22
@@ -38,6 +40,9 @@ main = do
38 where
40 where
39 allTests = concat
41 allTests = concat
40 [ makeGroup "micro" Micro.testCases
42 [ makeGroup "micro" Micro.testCases
43+#ifdef USE_TEMPLATE_HASKELL
44+ , makeGroup "TH" TH.testCases
45+#endif
41 , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40)
46 , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40)
42 , makeGroup "firing 1000" (Focused.firing 1000)
47 , makeGroup "firing 1000" (Focused.firing 1000)
43 , makeGroup "merge 100" (Focused.merging 100)
48 , makeGroup "merge 100" (Focused.merging 100)