git.iko.soy/reflex
on eb9d786 help sign in
90891e1
swap
3 ahead, 460 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+6−3
@@ -2,13 +2,15 @@
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+
8, data-default, filepath, directory, filemanip, ghcjs-base
9, data-default, filepath, directory, filemanip, ghcjs-base
9−, monoidal-containers, witherable
10+, monoidal-containers, witherable, generics-sop
10, useTemplateHaskell ? true
11, useTemplateHaskell ? true
11}:
12}:
13+
12mkDerivation {
14mkDerivation {
13 pname = "reflex";
15 pname = "reflex";
14 version = "0.5.0.1";
16 version = "0.5.0.1";
@@ -22,6 +24,7 @@ mkDerivation {
22 base bifunctors containers deepseq dependent-map dependent-sum
24 base bifunctors containers deepseq dependent-map dependent-sum
23 mtl ref-tf split transformers data-default
25 mtl ref-tf split transformers data-default
24 random time unbounded-delays monoidal-containers witherable
26 random time unbounded-delays monoidal-containers witherable
27+ generics-sop
25 ] ++ (if ghc.isGhcjs or false then [
28 ] ++ (if ghc.isGhcjs or false then [
26 ghcjs-base
29 ghcjs-base
27 ] else []) ++ (if !useTemplateHaskell then [] else [
30 ] else []) ++ (if !useTemplateHaskell then [] else [
reflex.cabal+18
@@ -47,6 +47,7 @@ library
47 data-default >= 0.5 && < 0.8,
47 data-default >= 0.5 && < 0.8,
48 dependent-map >= 0.2.4 && < 0.3,
48 dependent-map >= 0.2.4 && < 0.3,
49 exception-transformers == 0.4.*,
49 exception-transformers == 0.4.*,
50+ generics-sop >= 0.2.4.0,
50 lens >= 4.7 && < 5,
51 lens >= 4.7 && < 5,
51 monad-control >= 1.0.1 && < 1.1,
52 monad-control >= 1.0.1 && < 1.1,
52 monoidal-containers == 0.4.*,
53 monoidal-containers == 0.4.*,
@@ -74,6 +75,8 @@ library
74 Data.Functor.Misc,
75 Data.Functor.Misc,
75 Data.Map.Misc,
76 Data.Map.Misc,
76 Data.WeakBag,
77 Data.WeakBag,
78+ Generics.SOP.DMapUtilities,
79+ Generics.SOP.Distribute,
77 Reflex,
80 Reflex,
78 Reflex.Class,
81 Reflex.Class,
79 Reflex.Adjustable.Class,
82 Reflex.Adjustable.Class,
@@ -82,6 +85,7 @@ library
82 Reflex.Collection,
85 Reflex.Collection,
83 Reflex.Dynamic,
86 Reflex.Dynamic,
84 Reflex.Dynamic.Uniq,
87 Reflex.Dynamic.Uniq,
88+ Reflex.Dynamic.CollectDynGeneric,
85 Reflex.DynamicWriter,
89 Reflex.DynamicWriter,
86 Reflex.DynamicWriter.Base,
90 Reflex.DynamicWriter.Base,
87 Reflex.DynamicWriter.Class,
91 Reflex.DynamicWriter.Class,
@@ -154,6 +158,8 @@ test-suite semantics
154 main-is: semantics.hs
158 main-is: semantics.hs
155 hs-source-dirs: test
159 hs-source-dirs: test
156 ghc-options: -O2 -Wall -rtsopts
160 ghc-options: -O2 -Wall -rtsopts
161+ if flag(use-template-haskell)
162+ cpp-options: -DUSE_TEMPLATE_HASKELL
157 build-depends:
163 build-depends:
158 base,
164 base,
159 bifunctors,
165 bifunctors,
@@ -308,6 +314,18 @@ test-suite rootCleanup
308 Reflex.TestPlan
314 Reflex.TestPlan
309 Test.Run
315 Test.Run
310
316
317+test-suite mkDyn
318+ type: exitcode-stdio-1.0
319+ main-is: MkDyn.hs
320+ hs-source-dirs: test
321+ if !flag(use-template-haskell)
322+ buildable: False
323+ build-depends: base
324+ , reflex
325+ , deepseq
326+ , mtl
327+ , containers
328+
311benchmark spider-bench
329benchmark spider-bench
312 type: exitcode-stdio-1.0
330 type: exitcode-stdio-1.0
313 hs-source-dirs: bench test
331 hs-source-dirs: bench test
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 :: 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 :: 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. 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. (SListI2 xss) => NS (NP (f :.: g)) xss -> NS (NP f) (FunctorWrapTypeListOfLists g xss)
136+nsOfnpUnCompose = go sList where
137+ go :: forall 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. 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. (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) => 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
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+119
@@ -0,0 +1,119 @@
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. 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
107+ :: forall c f g xss
108+ . Dict (All2 c) xss
109+ -> (forall a. c a => f a -> g a)
110+ -> POP (f -.-> g) xss
111+functionPOPFromClass d f = withDict d $ hcpure (Proxy :: Proxy c) $ Fn f
112+
113+{-
114+functionPOPFromClass'::forall c f g xss.(All2 c xss, SListI2 xss)=>(forall a.c a=>f a -> g a)->POP (f -.-> g) xss
115+functionPOPFromClass' fn =
116+ let dict :: Dict (All2 c) xss
117+ dict = all_POP hdicts
118+ in withDict dict $ hcpure (Proxy :: Proxy c) $ Fn fn
119+-}
src/Reflex/Dynamic.hs+44−4
@@ -43,6 +43,7 @@ module Reflex.Dynamic
43 , maybeDyn
43 , maybeDyn
44 , eitherDyn
44 , eitherDyn
45 , factorDyn
45 , factorDyn
46+ , factorDynGeneric
46 , scanDyn
47 , scanDyn
47 , scanDynMaybe
48 , scanDynMaybe
48 , holdUniqDyn
49 , holdUniqDyn
@@ -76,7 +77,6 @@ module Reflex.Dynamic
76 , unsafeDynamic
77 , unsafeDynamic
77 ) where
78 ) where
78
79
79−import Data.Functor.Compose
80import Data.Functor.Misc
80import Data.Functor.Misc
81import Reflex.Class
81import Reflex.Class
82
82
@@ -87,11 +87,15 @@ import Data.Align
87import Data.Dependent.Map (DMap)
87import Data.Dependent.Map (DMap)
88import qualified Data.Dependent.Map as DMap
88import qualified Data.Dependent.Map as DMap
89import Data.Dependent.Sum (DSum (..))
89import Data.Dependent.Sum (DSum (..))
90+import Data.Functor.Compose (Compose (Compose), getCompose)
90import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))
91import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))
91import Data.Map (Map)
92import Data.Map (Map)
92−import Data.Maybe
93+import Data.Maybe (isJust)
93import Data.Monoid ((<>))
94import Data.Monoid ((<>))
94import Data.These
95import Data.These
96+import Generics.SOP ((:.:) (Comp), Code, Generic, I (I), Proxy (Proxy), SListI, SOP (SOP), from, hcmap, hmap, to, unSOP)
97+import Generics.SOP.Distribute (distributeI_NP)
98+import Generics.SOP.DMapUtilities (FunctorWrapTypeListOfLists, dSumToNS, nsOfnpUnCompose, nsToDSum)
95
99
96import Debug.Trace
100import Debug.Trace
97
101
@@ -308,6 +312,28 @@ eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum
308 LeftTag :=> Compose a -> Left $ coerceDynamic a
312 LeftTag :=> Compose a -> Left $ coerceDynamic a
309 RightTag :=> Compose b -> Right $ coerceDynamic b
313 RightTag :=> Compose b -> Right $ coerceDynamic b
310
314
315+-- | Use factorDyn and generics-sop to turn a Dynamic of a type into a factored
316+-- Dynamic of a type with Dynamic fields. For example:
317+--
318+-- > maybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe (Dynamic t a)))
319+-- > maybeDyn = factorDynGeneric
320+--
321+-- > eitherDyn :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Either a b) -> m (Dynamic t (Either (Dynamic t a) (Dynamic t b)))
322+-- > eitherDyn = factorDynGeneric
323+factorDynGeneric :: forall t m a b. (Reflex t, MonadFix m, MonadHold t m
324+ , Generic a, Generic b
325+ , (Code b) ~ FunctorWrapTypeListOfLists (Dynamic t) (Code a))
326+ => Dynamic t a -> m (Dynamic t b)
327+factorDynGeneric da = do
328+ let dSumDyn = nsToDSum . unSOP . from <$> da -- Dynamic t (DSum (TypeListTag (Code a)) (NP I xs))
329+ dSumDyn' <- factorDyn dSumDyn -- Dynamic t (DSum (TypeListTag (Code a)) (NP I))
330+ let nsnpDyn = dSumToNS <$> dSumDyn' -- Dynamic t (NS (Compose (Dynamic t) (NP I)) (Code a))
331+ sListIC = Proxy :: Proxy SListI
332+ nsnpDyn' = hcmap sListIC (hmap (Comp. I) . distributeI_NP . getCompose) <$> nsnpDyn -- Dynamic t (NS (NP (I :.: Dynamic t)) (Code a))
333+ nsnpDyn'' = nsOfnpUnCompose <$> nsnpDyn' -- Dynamic t (NS (NP I) (Code b))
334+ result = to . SOP <$> nsnpDyn''
335+ return result
336+
311factorDyn :: forall t m k v. (Reflex t, MonadHold t m, GEq k)
337factorDyn :: forall t m k v. (Reflex t, MonadHold t m, GEq k)
312 => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))
338 => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))
313factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where
339factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where
@@ -359,15 +385,22 @@ demuxed d k =
359 let e = select (demuxSelector d) (Const2 k)
385 let e = select (demuxSelector d) (Const2 k)
360 in unsafeBuildDynamic (fmap (==k) $ sample $ demuxValue d) e
386 in unsafeBuildDynamic (fmap (==k) $ sample $ demuxValue d) e
361
387
388+
362--------------------------------------------------------------------------------
389--------------------------------------------------------------------------------
363-- collectDyn
390-- collectDyn
364--------------------------------------------------------------------------------
391--------------------------------------------------------------------------------
365
392
366−--TODO: This whole section is badly in need of cleanup
393+-- | This is now deprecated in favor of types from the generics-sop library and
394+-- functions provided in Reflex.Dynamic.CollectDynGeneric
395+-- The generics-sop 'NP' product type takes the place of FHList and HList.
396+-- Utilities to manipulate the NP types (shifting functors from the type into and out of the type-list
397+-- and convert from NP to DMap and DMap to NP are all in Generics.SOP.DMapUtilities
398+-- Equivalent "distribute" and "collect" functions are now in Reflex.Dynamic.CollectDynGeneric
367
399
368-- | A heterogeneous list whose type and length are fixed statically. This is
400-- | A heterogeneous list whose type and length are fixed statically. This is
369-- reproduced from the 'HList' package due to integration issues, and because
401-- reproduced from the 'HList' package due to integration issues, and because
370-- very little other functionality from that library is needed.
402-- very little other functionality from that library is needed.
403+{-# 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" #-}
371data HList (l::[*]) where
404data HList (l::[*]) where
372 HNil :: HList '[]
405 HNil :: HList '[]
373 HCons :: e -> HList l -> HList (e ': l)
406 HCons :: e -> HList l -> HList (e ': l)
@@ -400,6 +433,7 @@ instance HBuild' (a ': l) r
400 hBuild' l x = hBuild' (HCons x l)
433 hBuild' l x = hBuild' (HCons x l)
401
434
402-- | Like 'HList', but with a functor wrapping each element.
435-- | Like 'HList', but with a functor wrapping each element.
436+{-# DEPRECATED FHList,RebuildSortedHList "This interface for type-level lists is being deprecated in favor of the 'NP' type from generics-sop" #-}
403data FHList f l where
437data FHList f l where
404 FHNil :: FHList f '[]
438 FHNil :: FHList f '[]
405 FHCons :: f e -> FHList f l -> FHList f (e ': l)
439 FHCons :: f e -> FHList f l -> FHList f (e ': l)
@@ -417,6 +451,7 @@ instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dma
417 HTailPtr a `gcompare` HTailPtr b = a `gcompare` b
451 HTailPtr a `gcompare` HTailPtr b = a `gcompare` b
418
452
419-- | A typed index into a typed heterogeneous list.
453-- | A typed index into a typed heterogeneous list.
454+{-# DEPRECATED HListPtr "Use 'Generics.SOP.DMapUtiltiies.TypeListTag' instead" #-}
420data HListPtr l a where
455data HListPtr l a where
421 HHeadPtr :: HListPtr (h ': t) h
456 HHeadPtr :: HListPtr (h ': t) h
422 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a
457 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a
@@ -424,6 +459,7 @@ data HListPtr l a where
424deriving instance Eq (HListPtr l a)
459deriving instance Eq (HListPtr l a)
425deriving instance Ord (HListPtr l a)
460deriving instance Ord (HListPtr l a)
426
461
462+{-# DEPRECATED fhlistToDMap "Use generics-sop 'NP' for your functor wrapped type-list and then 'Generics.SOP.DMapUtilities.npToDMap'" #-}
427fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f
463fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f
428fhlistToDMap = DMap.fromList . go
464fhlistToDMap = DMap.fromList . go
429 where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]
465 where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]
@@ -453,17 +489,20 @@ instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
453 ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
489 ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
454 _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"
490 _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"
455
491
492+{-# DEPRECATED dmapToHList "Use generics-sop 'NP' for your functor wrapped type-list and then 'Generics.SOP.DMapUtilities.dMapToNP'" #-}
456dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l
493dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l
457dmapToHList = rebuildSortedHList . DMap.toList
494dmapToHList = rebuildSortedHList . DMap.toList
458
495
459-- | Collect a hetereogeneous list whose elements are all 'Dynamic's into a
496-- | Collect a hetereogeneous list whose elements are all 'Dynamic's into a
460-- single 'Dynamic' whose value represents the current values of all of the
497-- single 'Dynamic' whose value represents the current values of all of the
461-- input 'Dynamic's.
498-- input 'Dynamic's.
499+{-# DEPRECATED distributeFHListOverDynPure "Use the generics-sop 'NP' type for functor-wrapped type-lists and then 'Reflex.Dynamic.CollectDynGeneric.collectDynNP' " #-}
462distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l)
500distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l)
463distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l
501distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l
464
502
465-- | Indicates that all elements in a type-level list are applications of the
503-- | Indicates that all elements in a type-level list are applications of the
466-- same functor.
504-- same functor.
505+{-# DEPRECATED AllAreFunctors "This functionality is provided for generics-sop 'NP' via 'Generics.SOP.DMapUtilties.npUnCompose' and 'Generics.SOP.DMapUtilities.npReCompose'" #-}
467class AllAreFunctors (f :: a -> *) (l :: [a]) where
506class AllAreFunctors (f :: a -> *) (l :: [a]) where
468 type FunctorList f l :: [*]
507 type FunctorList f l :: [*]
469 toFHList :: HList (FunctorList f l) -> FHList f l
508 toFHList :: HList (FunctorList f l) -> FHList f l
@@ -489,7 +528,8 @@ instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
489
528
490-- | Convert a datastructure whose constituent parts are all 'Dynamic's into a
529-- | Convert a datastructure whose constituent parts are all 'Dynamic's into a
491-- single 'Dynamic' whose value represents all the current values of the input's
530-- single 'Dynamic' whose value represents all the current values of the input's
492−-- constituent 'Dynamic's.
531+-- consitutent 'Dynamic's.
532+{-# DEPRECATED collectDynPure "Use 'Reflex.Dynamic.CollectDynGeneric.collectDynGeneric' instead." #-}
493collectDynPure :: ( RebuildSortedHList (HListElems b)
533collectDynPure :: ( RebuildSortedHList (HListElems b)
494 , IsHList a, IsHList b
534 , IsHList a, IsHList b
495 , AllAreFunctors (Dynamic t) (HListElems b)
535 , 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+5−4
@@ -15,7 +15,8 @@ module Reflex.Dynamic.TH
15 , mkDynPure
15 , mkDynPure
16 ) where
16 ) where
17
17
18−import Reflex.Dynamic
18+import Generics.SOP (I (..), NP (..))
19+import Reflex.Dynamic.CollectDynGeneric (collectDynNP)
19
20
20import Control.Monad.State
21import Control.Monad.State
21import Data.Data
22import Data.Data
@@ -44,9 +45,9 @@ qDynPure qe = do
44 _ -> gmapM f d
45 _ -> gmapM f d
45 (e', exprsReversed) <- runStateT (gmapM f e) []
46 (e', exprsReversed) <- runStateT (gmapM f e) []
46 let exprs = reverse exprsReversed
47 let exprs = reverse exprsReversed
47− arg = foldr (\a b -> ConE 'FHCons `AppE` snd a `AppE` b) (ConE 'FHNil) exprs
48+ arg = foldr (\a b -> ConE '(:*) `AppE` a `AppE` b) (ConE 'Nil) $ map snd exprs
48− param = foldr (\a b -> ConP 'HCons [VarP (fst a), b]) (ConP 'HNil []) exprs
49+ param = foldr (\a b -> ConP '(:*) [ConP 'I [VarP a], b]) (ConP 'Nil []) $ map fst exprs
49− [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |]
50+ [| $(return $ LamE [param] e') <$> collectDynNP $(return arg) |]
50
51
51-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a
52-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a
52-- 'qDyn' quotation.
53-- '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)