From b2971d8516fb341f2167fbcff33daa21e8d9265b Mon Sep 17 00:00:00 2001 From: adamConnerSax Date: Tue, 25 Apr 2017 10:42:09 -0400 Subject: [PATCH 01/11] Working qDynPure maybe. Plus new CollectDynGeneric code. And new testcases. --- .gitignore | 1 + reflex.cabal | 2 + src/Reflex/Class.hs | 19 +++ src/Reflex/Dynamic/CollectDynGeneric.hs | 180 ++++++++++++++++++++++++ src/Reflex/Dynamic/TH.hs | 24 ++++ stack.yaml | 76 ++++++++++ test/Reflex/Test/TH.hs | 26 ++++ test/semantics.hs | 2 + 8 files changed, 330 insertions(+) create mode 100644 src/Reflex/Dynamic/CollectDynGeneric.hs create mode 100644 stack.yaml create mode 100644 test/Reflex/Test/TH.hs diff --git a/.gitignore b/.gitignore index 7823a5f7..c8814f19 100644 --- a/.gitignore +++ b/.gitignore @@ -36,3 +36,4 @@ hsenv.log /ghci-tmp *.dump-* *.verbose-core2core +.stack-work/* \ No newline at end of file diff --git a/reflex.cabal b/reflex.cabal index e89b7da4..6e843998 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -48,6 +48,7 @@ library data-default >= 0.5 && < 0.8, dependent-map >= 0.2.4 && < 0.3, exception-transformers == 0.4.*, + generics-sop >= 0.2.4.0, lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1, mtl >= 2.1 && < 2.3, @@ -71,6 +72,7 @@ library Reflex.EventWriter, Reflex.Dynamic, Reflex.Dynamic.Uniq, + Reflex.Dynamic.CollectDynGeneric Reflex.DynamicWriter, Reflex.FunctorMaybe, Reflex.Host.Class, diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index fdffcbf7..eba06273 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -163,6 +163,7 @@ import Data.Either import Data.Foldable import Data.Functor.Bind hiding (join) import qualified Data.Functor.Bind as Bind +import Data.Functor.Compose (Compose(..)) import Data.Functor.Constant import Data.Functor.Misc import Data.Functor.Plus @@ -252,6 +253,7 @@ class ( MonadHold t (PushM t) -- least one input event is occuring, and will contain all of the input keys -- that are occurring simultaneously merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty +-- mergeWithFunctor :: (GCompare k, Functor f) => DMap k (Compose (Event t) f) -> Event t (DMap k f) -- | Efficiently fan-out an event to many destinations. This function should -- be partially applied, and then the result applied repeatedly to create -- child events @@ -308,6 +310,7 @@ push :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b pushCheap :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b pull :: Reflex t => PullM t a -> Behavior t a merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity) +mergeWithFunctor :: (Reflex t, GCompare k, Functor f) => DMap k (Compose (Event t) f) -> Event t (DMap k f) fan :: (Reflex t, GCompare k) => Event t (DMap k Identity) -> EventSelector t k switch :: Reflex t => Behavior t (Event t a) -> Event t a coincidence :: Reflex t => Event t (Event t a) -> Event t a @@ -335,6 +338,8 @@ pushCheap f = SpiderEvent . S.pushCheap (coerce f) . unSpiderEvent pull = SpiderBehavior . S.pull . coerce {-# INLINE merge #-} merge = SpiderEvent . S.merge . S.dynamicConst . (coerce :: DMap k (Event (SpiderTimeline x)) -> DMap k (S.Event x)) +--{-# INLINE mergeWithFunctor #-} +--mergeWithFunctor = SpiderEvent . S.merge . S.dynamicConst . {-# INLINE fan #-} fan e = EventSelector $ SpiderEvent . S.select (S.fan (unSpiderEvent e)) {-# INLINE switch #-} @@ -796,6 +801,20 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where -- | This function converts a 'DMap' whose elements are 'Dynamic's into a -- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same -- through the use of multiple uses of 'zipWithDyn' or 'Applicative' operators. +{- +distributeDMapOverDynPureWithFunctor :: forall t k f.(Reflex t, GCompare k, Functor f) => DMap k (Compose (Dynamic t) f) -> Dynamic t (DMap k f) +distributeDMapOverDynPureWithFunctor dm = case DMap.toList dm of + [] -> constDyn DMap.empty + [k :=> fv] -> fmap (DMap.singleton k) fv + _ -> + let getInitial = DMap.traverseWithKey (\_ -> sample . current . getCompose) dm --uses the applicative instance of MonadSample? + edmPre = merge $ DMap.map (updated . getCompose) dm + result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do + olds <- sample $ current result + return $ DMap.unionWithKey (\_ _ new -> new) olds news + in result +-} + distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity) distributeDMapOverDynPure dm = case DMap.toList dm of [] -> constDyn DMap.empty diff --git a/src/Reflex/Dynamic/CollectDynGeneric.hs b/src/Reflex/Dynamic/CollectDynGeneric.hs new file mode 100644 index 00000000..6df15af3 --- /dev/null +++ b/src/Reflex/Dynamic/CollectDynGeneric.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} -- only requried for copied section +{-# LANGUAGE FlexibleInstances #-} -- only required for copied section +{-# OPTIONS -fno-warn-unused-imports #-} +{-# OPTIONS -fno-warn-unused-top-binds #-} +{-| +Module: Reflex.Dynamic.CollectDynGeneric +Description: Generic (generics-sop) implementation of CollectDynPure and distributeFHListOverDynPure +-} +module Reflex.Dynamic.CollectDynGeneric + ( + distributeNPOverDyn + , collectDynGeneric + , collectDynPureNP + ) where + +import Generics.SOP (NS, NP,SListI, SListI2, hmap,I(I),unI + , (:.:)(Comp),unComp,from,to, Generic + ,Code,SOP(..),unSOP + ,hsequence',hliftA, hcliftA, Proxy(..)) + + +import Reflex.Class (Reflex) -- where is the canonical, least surface area place, to get this? +import Reflex.Dynamic (Dynamic,distributeDMapOverDynPure) + +-- these imports only for the copied section +import Generics.SOP (hmap,hcollapse,NS(..),NP(..),SListI(..) + ,SListI2,SList(..),All2,Compose + ,FieldInfo,ConstructorInfo,K(..) + , type (-.->)(Fn), (:.:)(Comp), unComp,Proxy(..)) +import Generics.SOP.NP (sequence'_NP) +import Generics.SOP.NS (ap_NS) +import Generics.SOP.Dict (Dict(Dict),withDict) + +import qualified Data.Dependent.Map as DM +import Data.Dependent.Sum (DSum ((:=>))) +import qualified Data.Dependent.Sum as DS + +import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), + GOrdering (..)) + +import Data.Functor.Identity (Identity(Identity,runIdentity)) +import Data.Maybe (fromJust) +-- end imports for copied section + +distributeNPOverDyn::(Reflex t, SListI xs)=>NP I (FunctorWrapTypeList (Dynamic t) xs) -> Dynamic t (NP I xs) +distributeNPOverDyn = collectDynPureNP . hliftA (unI . unComp) . npReCompose + +collectDynGeneric::(Reflex t,Generic a, Generic b, (Code a) ~ FunctorWrapTypeListOfLists (Dynamic t) (Code b))=>a -> Dynamic t b +collectDynGeneric = fmap (to . SOP) . hsequence' . collectDynPureNSNP . aToNSNPI + +aToNSNPI::(Generic a, Code a ~ FunctorWrapTypeListOfLists (Dynamic t) xss, SListI2 xss) =>a -> NS (NP (I :.: Dynamic t)) xss +aToNSNPI = nsOfnpReCompose . unSOP . from + +collectDynPureNSNP::(Reflex t,SListI2 xss)=>NS (NP (I :.: Dynamic t)) xss -> NS (Dynamic t :.: NP I) xss +collectDynPureNSNP = + let slistIC = Proxy :: Proxy SListI + in hcliftA slistIC (Comp . collectDynPureNP . hliftA (unI . unComp)) + +collectDynPureNP::(Reflex t, SListI xs)=>NP (Dynamic t) xs -> Dynamic t (NP I xs) +collectDynPureNP = npSequenceViaDMap distributeDMapOverDynPure . hliftA (Comp . fmap I) + +{- + This is copied from perConstructor-sop until it's released. + should be replaced by an import: + +import Generics.SOP.DMapUtilities (npSequenceViaDMap,npReCompose,nsOfnpReCompose + ,FunctorWrapTypeList,FunctorWrapTypeListOfLists) +-} +-- |A Tag type for making DMaps of type-level lists +data TypeListTag (xs :: [k]) (x :: k) where -- x is in xs + Here :: TypeListTag (x ': xs) x -- x begins xs + There :: TypeListTag xs x -> TypeListTag (y ': xs) x -- given that x is in xs, x is also in (y ': xs) + +instance GEq (TypeListTag xs) where + geq Here Here = Just Refl + geq (There x) (There y) = geq x y + geq _ _ = Nothing + +instance GCompare (TypeListTag xs) where + gcompare Here Here = GEQ + gcompare Here (There _) = GLT + gcompare (There _) Here = GGT + gcompare (There x) (There y) = gcompare x y + + + +-- |Convert an 'NP' indexed by typelist xs into a 'DM.DMap' indexed by 'TypeListTag' xs +npToDMap::NP f xs -> DM.DMap (TypeListTag xs) f +npToDMap Nil = DM.empty +npToDMap (fx :* np') = DM.insert Here fx $ DM.mapKeysMonotonic There $ npToDMap np' + +-- |Convert a 'DM.DMap' indexed by 'TypeListTag' xs to an 'NP' +-- |NB: This can fail since there is no guarantee that the 'DM.DMap' has entries for every tag. Hence it returns a 'Maybe' +dMapToNP::forall xs f.SListI xs=>DM.DMap (TypeListTag xs) f -> Maybe (NP f xs) +dMapToNP dm = sequence'_NP $ hmap (\tag -> Comp $ DM.lookup tag dm) makeTypeListTagNP + +-- |Convert a 'NS' indexed by a typelist xs to a 'DS.DSum' indexed by 'TypeListTag' xs +nsToDSum::SListI xs=>NS f xs -> DS.DSum (TypeListTag xs) f +nsToDSum ns = + let nsFToNSDSum::SListI xs=>NS f xs -> NS (K (DS.DSum (TypeListTag xs) f)) xs + nsFToNSDSum ns' = ap_NS (tagsToFs makeTypeListTagNP) ns' + tagsToFs::SListI xs=>NP (TypeListTag xs) xs -> NP (f -.-> K (DS.DSum (TypeListTag xs) f)) xs + tagsToFs = hmap (\tag -> (Fn $ \val -> K (tag :=> val))) + in hcollapse $ nsFToNSDSum ns + +-- |Convert a 'DS.DSum' indexed by 'TypeListTag' xs into a 'NS' indexed by xs +dSumToNS::SListI xs=>DS.DSum (TypeListTag xs) f -> NS f xs +dSumToNS (tag :=> fa) = go tag fa where + go::TypeListTag ys y->f y->NS f ys + go Here fy = Z fy + go (There tag') fy = S (go tag' fy) + +makeTypeListTagNP::SListI xs=>NP (TypeListTag xs) xs +makeTypeListTagNP = go sList where + go::forall ys.SListI ys=>SList ys->NP (TypeListTag ys) ys + go SNil = Nil + go SCons = Here :* hmap There (go sList) + + +-- these are here to allow moving functors in and out of typelists +type family FunctorWrapTypeList (f :: * -> *) (xs :: [*]) :: [*] where + FunctorWrapTypeList f '[] = '[] + FunctorWrapTypeList f (x ': xs) = f x ': FunctorWrapTypeList f xs + +type family FunctorWrapTypeListOfLists (f :: * -> *) (xss :: [[*]]) :: [[*]] where + FunctorWrapTypeListOfLists f '[] = '[] + FunctorWrapTypeListOfLists f (xs ': xss') = FunctorWrapTypeList f xs ': FunctorWrapTypeListOfLists f xss' + +npUnCompose::forall f g xs.SListI xs=>NP (f :.: g) xs -> NP f (FunctorWrapTypeList g xs) +npUnCompose np = go np where + go::NP (f :.: g) ys -> NP f (FunctorWrapTypeList g ys) + go Nil = Nil + go (fgx :* np') = unComp fgx :* go np' + + +npReCompose::forall f g xs.SListI xs=>NP f (FunctorWrapTypeList g xs) -> NP (f :.: g) xs -- (RemoveFunctor g (AddFunctor g xs)) +npReCompose = go sList where + go::forall ys.SListI ys=>SList ys -> NP f (FunctorWrapTypeList g ys) -> NP (f :.: g) ys + go SNil Nil = Nil + go SCons (fgx :* np') = Comp fgx :* go sList np' + +nsOfnpReCompose::forall f g xss.(SListI xss, SListI2 xss)=>NS (NP f) (FunctorWrapTypeListOfLists g xss) -> NS (NP (f :.: g)) xss +nsOfnpReCompose = go sList + where + go::forall yss.(SListI2 yss, SListI yss)=>SList yss->NS (NP f) (FunctorWrapTypeListOfLists g yss) -> NS (NP (f :.: g)) yss + go SNil _ = undefined -- this shouldn't' happen since an NS can't be empty + go SCons (Z np) = Z (npReCompose np) + go SCons (S ns') = S (go sList ns') + + +-- required to prove the wrapped typelist is an instance of SListI +functorWrappedSListIsSList :: forall f xs . SListI xs=>Proxy f -> SList xs -> Dict SListI (FunctorWrapTypeList f xs) +functorWrappedSListIsSList _ SNil = Dict +functorWrappedSListIsSList pf SCons = goCons (sList :: SList xs) + where + goCons :: forall y ys . SList (y ': ys) -> Dict SListI (FunctorWrapTypeList f (y ': ys)) + goCons SCons = withDict (functorWrappedSListIsSList pf (sList :: SList ys)) Dict + + +-- NB: THe fromJust in there is safe! +-- dMapToNP has to return Maybe NP since the DMap could be incomplete. +-- But since we built this DMap from an NP, we know it's complete and dMapToNp will return a Just. +npSequenceViaDMap::forall k (f:: * -> *) (g:: * -> *) (xs::[*]).(Functor f + , SListI xs + , DM.GCompare k + , k ~ TypeListTag (FunctorWrapTypeList g xs)) + =>(DM.DMap k f -> f (DM.DMap k Identity))->NP (f :.: g) xs -> f (NP g xs) +npSequenceViaDMap sequenceDMap = + withDict (functorWrappedSListIsSList (Proxy :: Proxy g) (sList :: SList xs)) $ + fmap (hmap (runIdentity . unComp) . npReCompose . fromJust . dMapToNP) . sequenceDMap . npToDMap . npUnCompose +-- End copied section diff --git a/src/Reflex/Dynamic/TH.hs b/src/Reflex/Dynamic/TH.hs index 3327ffc3..4fc0f4eb 100644 --- a/src/Reflex/Dynamic/TH.hs +++ b/src/Reflex/Dynamic/TH.hs @@ -20,6 +20,9 @@ module Reflex.Dynamic.TH import Reflex.Dynamic +import Reflex.Dynamic.CollectDynGeneric +import Generics.SOP (NP(..),I(..)) + import Control.Monad.State import Data.Data import Data.Generics @@ -33,6 +36,7 @@ import qualified Language.Haskell.TH.Syntax as TH -- | Quote a 'Dynamic' expression. Within the quoted expression, you can use -- @$(unqDyn [| x |])@ to refer to any expression @x@ of type @Dynamic t a@; the -- unquoted result will be of type @a@ +{- qDynPure :: Q Exp -> Q Exp qDynPure qe = do e <- qe @@ -50,6 +54,26 @@ qDynPure qe = do arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |] +-} + +qDynPure :: Q Exp -> Q Exp +qDynPure qe = do + e <- qe + let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d + f d = case eqT of + Just (Refl :: d :~: Exp) + | AppE (VarE m) eInner <- d + , m == 'unqMarker + -> do n <- lift $ newName "dynamicQuotedExpressionVariable" + modify ((n, eInner):) + return $ VarE n + _ -> gmapM f d + (e', exprsReversed) <- runStateT (gmapM f e) [] + let exprs = reverse exprsReversed + arg = foldr (\a b -> ConE '(:*) `AppE` a `AppE` b) (ConE 'Nil) $ map snd exprs + param = foldr (\a b -> ConP '(:*) [ConP 'I [VarP a], b]) (ConP 'Nil []) $ map fst exprs + [| $(return $ LamE [param] e') <$> collectDynPureNP $(return arg) |] + -- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a -- 'qDyn' quotation. diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 00000000..a338170c --- /dev/null +++ b/stack.yaml @@ -0,0 +1,76 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# A warning or info to be displayed to the user on config load. +user-message: ! 'Warning (added by new or init): Specified resolver could not satisfy + all dependencies. Some external packages have been added as dependencies. + + You can suppress this message by removing it from stack.yaml + +' + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-8.11 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- '.' +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: +- prim-uniq-0.1.0.1 +- ref-tf-0.4.0.1 + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.4" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor \ No newline at end of file diff --git a/test/Reflex/Test/TH.hs b/test/Reflex/Test/TH.hs new file mode 100644 index 00000000..ffca7d2b --- /dev/null +++ b/test/Reflex/Test/TH.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE GADTs #-} +module Reflex.Test.TH (testCases) where + +import Reflex +import Reflex.Dynamic.TH + +import Reflex.TestPlan + +testCases :: [(String, TestCase)] +testCases = + [ + testE "mkDynPure" $ do + dyn1 <- holdDyn 0 =<< events1 + dyn2 <- holdDyn 0 =<< events2 + let dynResult = [mkDynPure|$dyn1 + $dyn2|] + return $ updated dynResult + ] where + + events1, events2 :: TestPlan t m => m (Event t Int) + events1 = plan [(1, 1), (11, 2), (21, 3), (31, 4), (41, 5)] + events2 = plan [(5, 10), (15, 20), (25, 30), (35, 40), (45, 50)] + + + + diff --git a/test/semantics.hs b/test/semantics.hs index b633368d..858c4a3f 100644 --- a/test/semantics.hs +++ b/test/semantics.hs @@ -14,6 +14,7 @@ import Data.Functor import Data.List import qualified Reflex.Bench.Focused as Focused import qualified Reflex.Test.Micro as Micro +import qualified Reflex.Test.TH as TH import System.Environment import System.Exit @@ -38,6 +39,7 @@ main = do where allTests = concat [ makeGroup "micro" Micro.testCases + , makeGroup "TH" TH.testCases , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40) , makeGroup "firing 1000" (Focused.firing 1000) , makeGroup "merge 100" (Focused.merging 100) From 06f97920c1c6ffd183ecb681bc7d27e7ea100623 Mon Sep 17 00:00:00 2001 From: adamConnerSax Date: Tue, 25 Apr 2017 10:54:29 -0400 Subject: [PATCH 02/11] Removed some unneeded changes in Reflex/Class.hs --- src/Reflex/Class.hs | 19 ------------------- src/Reflex/Dynamic/TH.hs | 20 -------------------- 2 files changed, 39 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index eba06273..fdffcbf7 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -163,7 +163,6 @@ import Data.Either import Data.Foldable import Data.Functor.Bind hiding (join) import qualified Data.Functor.Bind as Bind -import Data.Functor.Compose (Compose(..)) import Data.Functor.Constant import Data.Functor.Misc import Data.Functor.Plus @@ -253,7 +252,6 @@ class ( MonadHold t (PushM t) -- least one input event is occuring, and will contain all of the input keys -- that are occurring simultaneously merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty --- mergeWithFunctor :: (GCompare k, Functor f) => DMap k (Compose (Event t) f) -> Event t (DMap k f) -- | Efficiently fan-out an event to many destinations. This function should -- be partially applied, and then the result applied repeatedly to create -- child events @@ -310,7 +308,6 @@ push :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b pushCheap :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b pull :: Reflex t => PullM t a -> Behavior t a merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity) -mergeWithFunctor :: (Reflex t, GCompare k, Functor f) => DMap k (Compose (Event t) f) -> Event t (DMap k f) fan :: (Reflex t, GCompare k) => Event t (DMap k Identity) -> EventSelector t k switch :: Reflex t => Behavior t (Event t a) -> Event t a coincidence :: Reflex t => Event t (Event t a) -> Event t a @@ -338,8 +335,6 @@ pushCheap f = SpiderEvent . S.pushCheap (coerce f) . unSpiderEvent pull = SpiderBehavior . S.pull . coerce {-# INLINE merge #-} merge = SpiderEvent . S.merge . S.dynamicConst . (coerce :: DMap k (Event (SpiderTimeline x)) -> DMap k (S.Event x)) ---{-# INLINE mergeWithFunctor #-} ---mergeWithFunctor = SpiderEvent . S.merge . S.dynamicConst . {-# INLINE fan #-} fan e = EventSelector $ SpiderEvent . S.select (S.fan (unSpiderEvent e)) {-# INLINE switch #-} @@ -801,20 +796,6 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where -- | This function converts a 'DMap' whose elements are 'Dynamic's into a -- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same -- through the use of multiple uses of 'zipWithDyn' or 'Applicative' operators. -{- -distributeDMapOverDynPureWithFunctor :: forall t k f.(Reflex t, GCompare k, Functor f) => DMap k (Compose (Dynamic t) f) -> Dynamic t (DMap k f) -distributeDMapOverDynPureWithFunctor dm = case DMap.toList dm of - [] -> constDyn DMap.empty - [k :=> fv] -> fmap (DMap.singleton k) fv - _ -> - let getInitial = DMap.traverseWithKey (\_ -> sample . current . getCompose) dm --uses the applicative instance of MonadSample? - edmPre = merge $ DMap.map (updated . getCompose) dm - result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do - olds <- sample $ current result - return $ DMap.unionWithKey (\_ _ new -> new) olds news - in result --} - distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity) distributeDMapOverDynPure dm = case DMap.toList dm of [] -> constDyn DMap.empty diff --git a/src/Reflex/Dynamic/TH.hs b/src/Reflex/Dynamic/TH.hs index 4fc0f4eb..fb838d5f 100644 --- a/src/Reflex/Dynamic/TH.hs +++ b/src/Reflex/Dynamic/TH.hs @@ -36,26 +36,6 @@ import qualified Language.Haskell.TH.Syntax as TH -- | Quote a 'Dynamic' expression. Within the quoted expression, you can use -- @$(unqDyn [| x |])@ to refer to any expression @x@ of type @Dynamic t a@; the -- unquoted result will be of type @a@ -{- -qDynPure :: Q Exp -> Q Exp -qDynPure qe = do - e <- qe - let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d - f d = case eqT of - Just (Refl :: d :~: Exp) - | AppE (VarE m) eInner <- d - , m == 'unqMarker - -> do n <- lift $ newName "dynamicQuotedExpressionVariable" - modify ((n, eInner):) - return $ VarE n - _ -> gmapM f d - (e', exprsReversed) <- runStateT (gmapM f e) [] - let exprs = reverse exprsReversed - arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs - param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs - [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |] --} - qDynPure :: Q Exp -> Q Exp qDynPure qe = do e <- qe From 34b2802e58f5945a226bb40e23479c0487668d8a Mon Sep 17 00:00:00 2001 From: adamConnerSax Date: Tue, 25 Apr 2017 16:11:08 -0400 Subject: [PATCH 03/11] Rearranged DMapUtilties into their eventual module location, added CPP for mkDynPure test. --- default.nix | 12 +- reflex.cabal | 5 +- src/Generics/SOP/DMapUtilities.hs | 166 ++++++++++++++++++++++++ src/Reflex/Dynamic/CollectDynGeneric.hs | 133 +------------------ stack.yaml | 4 +- test/Reflex/Test/TH.hs | 2 +- test/semantics.hs | 14 +- 7 files changed, 193 insertions(+), 143 deletions(-) create mode 100644 src/Generics/SOP/DMapUtilities.hs diff --git a/default.nix b/default.nix index 4bbba774..68bed6b3 100644 --- a/default.nix +++ b/default.nix @@ -1,10 +1,10 @@ { mkDerivation, ghc, base, bifunctors, containers, deepseq , dependent-map, dependent-sum, exception-transformers -, haskell-src-exts, haskell-src-meta, hlint, lens, MemoTrie -, monad-control, mtl, primitive, ref-tf, semigroupoids -, semigroups, split, stdenv, stm, syb, template-haskell -, these, transformers, transformers-compat, prim-uniq -, data-default +, generics-sop, haskell-src-exts, haskell-src-meta, hlint +, lens, MemoTrie, monad-control, mtl, primitive, ref-tf +, semigroupoids, semigroups, split, stdenv, stm, syb +, template-haskell, these, transformers +, transformers-compat, prim-uniq , data-default , useTemplateHaskell ? true }: mkDerivation { @@ -18,7 +18,7 @@ mkDerivation { semigroups stm syb template-haskell these transformers transformers-compat prim-uniq base bifunctors containers deepseq dependent-map dependent-sum - mtl ref-tf split transformers data-default + mtl ref-tf split transformers data-default generics-sop ] ++ (if !useTemplateHaskell then [] else [ haskell-src-exts haskell-src-meta ]); diff --git a/reflex.cabal b/reflex.cabal index 6e843998..90a946eb 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -67,6 +67,7 @@ library exposed-modules: Data.Functor.Misc, Data.WeakBag, + Generics.SOP.DMapUtilities, Reflex, Reflex.Class, Reflex.EventWriter, @@ -87,7 +88,7 @@ library Reflex.Requester.Class, Reflex.Spider, Reflex.Spider.Internal - + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 ghc-prof-options: -fprof-auto @@ -127,6 +128,8 @@ test-suite semantics main-is: semantics.hs hs-source-dirs: test ghc-options: -O2 -Wall -rtsopts + if flag(use-template-haskell) + cpp-options: -DUSE_TEMPLATE_HASKELL build-depends: base, bifunctors, diff --git a/src/Generics/SOP/DMapUtilities.hs b/src/Generics/SOP/DMapUtilities.hs new file mode 100644 index 00000000..7439e1de --- /dev/null +++ b/src/Generics/SOP/DMapUtilities.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-| +Module : Generics.SOP.DMapUtilities +Description : Utilities for converting between the NS/NP types of generics-sop and Dependent Maps. +-} + +module Generics.SOP.DMapUtilities + ( + -- * Type Functions + -- ** Add functors around types in a typelist or typelist of typelists + FunctorWrapTypeList + , FunctorWrapTypeListOfLists + + -- * Types + , TypeListTag + + -- * Conversions + -- ** NP <-> DMap + , npToDMap + , dMapToNP + -- ** NS <-> DSum + , nsToDSum + , dSumToNS + + -- * Functor wrapping/unwrapping utilities for 'NP' + , npUnCompose + , npReCompose + , nsOfnpReCompose + + -- * Utilities + , npSequenceViaDMap + -- * Proofs + + , functorWrappedSListIsSList + )where + +import Generics.SOP (hmap,hcollapse,NS(..),NP(..),SListI(..) + ,SListI2,SList(..),K(..) + , type (-.->)(Fn), (:.:)(Comp), unComp,Proxy(..)) +import Generics.SOP.NP (sequence'_NP) +import Generics.SOP.NS (ap_NS) +import Generics.SOP.Dict (Dict(Dict),withDict) + +import qualified Data.Dependent.Map as DM +import Data.Dependent.Sum (DSum ((:=>))) +import qualified Data.Dependent.Sum as DS + +import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), + GOrdering (..)) + + +import Data.Functor.Identity (Identity(runIdentity)) + + +-- |A Tag type for making DMaps of type-level lists +data TypeListTag (xs :: [k]) (x :: k) where -- x is in xs + Here :: TypeListTag (x ': xs) x -- x begins xs + There :: TypeListTag xs x -> TypeListTag (y ': xs) x -- given that x is in xs, x is also in (y ': xs) + +instance GEq (TypeListTag xs) where + geq Here Here = Just Refl + geq (There x) (There y) = geq x y + geq _ _ = Nothing + +instance GCompare (TypeListTag xs) where + gcompare Here Here = GEQ + gcompare Here (There _) = GLT + gcompare (There _) Here = GGT + gcompare (There x) (There y) = gcompare x y + + + +-- |Convert an 'NP' indexed by typelist xs into a 'DM.DMap' indexed by 'TypeListTag' xs +npToDMap::NP f xs -> DM.DMap (TypeListTag xs) f +npToDMap Nil = DM.empty +npToDMap (fx :* np') = DM.insert Here fx $ DM.mapKeysMonotonic There $ npToDMap np' + +-- |Convert a 'DM.DMap' indexed by 'TypeListTag' xs to an 'NP' +-- |NB: This can fail since there is no guarantee that the 'DM.DMap' has entries for every tag. Hence it returns a 'Maybe' +dMapToNP::forall xs f.SListI xs=>DM.DMap (TypeListTag xs) f -> Maybe (NP f xs) +dMapToNP dm = sequence'_NP $ hmap (\tag -> Comp $ DM.lookup tag dm) makeTypeListTagNP + +-- |Convert a 'NS' indexed by a typelist xs to a 'DS.DSum' indexed by 'TypeListTag' xs +nsToDSum::SListI xs=>NS f xs -> DS.DSum (TypeListTag xs) f +nsToDSum ns = + let nsFToNSDSum::SListI xs=>NS f xs -> NS (K (DS.DSum (TypeListTag xs) f)) xs + nsFToNSDSum ns' = ap_NS (tagsToFs makeTypeListTagNP) ns' + tagsToFs::SListI xs=>NP (TypeListTag xs) xs -> NP (f -.-> K (DS.DSum (TypeListTag xs) f)) xs + tagsToFs = hmap (\tag -> (Fn $ \val -> K (tag :=> val))) + in hcollapse $ nsFToNSDSum ns + +-- |Convert a 'DS.DSum' indexed by 'TypeListTag' xs into a 'NS' indexed by xs +dSumToNS::SListI xs=>DS.DSum (TypeListTag xs) f -> NS f xs +dSumToNS (tag :=> fa) = go tag fa where + go::TypeListTag ys y->f y->NS f ys + go Here fy = Z fy + go (There tag') fy = S (go tag' fy) + +makeTypeListTagNP::SListI xs=>NP (TypeListTag xs) xs +makeTypeListTagNP = go sList where + go::forall ys.SListI ys=>SList ys->NP (TypeListTag ys) ys + go SNil = Nil + go SCons = Here :* hmap There (go sList) + + +-- these are here to allow moving functors in and out of typelists +type family FunctorWrapTypeList (f :: * -> *) (xs :: [*]) :: [*] where + FunctorWrapTypeList f '[] = '[] + FunctorWrapTypeList f (x ': xs) = f x ': FunctorWrapTypeList f xs + +type family FunctorWrapTypeListOfLists (f :: * -> *) (xss :: [[*]]) :: [[*]] where + FunctorWrapTypeListOfLists f '[] = '[] + FunctorWrapTypeListOfLists f (xs ': xss') = FunctorWrapTypeList f xs ': FunctorWrapTypeListOfLists f xss' + +npUnCompose::forall f g xs.SListI xs=>NP (f :.: g) xs -> NP f (FunctorWrapTypeList g xs) +npUnCompose np = go np where + go::NP (f :.: g) ys -> NP f (FunctorWrapTypeList g ys) + go Nil = Nil + go (fgx :* np') = unComp fgx :* go np' + + +npReCompose::forall f g xs.SListI xs=>NP f (FunctorWrapTypeList g xs) -> NP (f :.: g) xs -- (RemoveFunctor g (AddFunctor g xs)) +npReCompose = go sList where + go::forall ys.SListI ys=>SList ys -> NP f (FunctorWrapTypeList g ys) -> NP (f :.: g) ys + go SNil Nil = Nil + go SCons (fgx :* np') = Comp fgx :* go sList np' + +nsOfnpReCompose::forall f g xss.(SListI xss, SListI2 xss)=>NS (NP f) (FunctorWrapTypeListOfLists g xss) -> NS (NP (f :.: g)) xss +nsOfnpReCompose = go sList + where + go::forall yss.(SListI2 yss, SListI yss)=>SList yss->NS (NP f) (FunctorWrapTypeListOfLists g yss) -> NS (NP (f :.: g)) yss + go SNil _ = undefined -- this shouldn't' happen since an NS can't be empty + go SCons (Z np) = Z (npReCompose np) + go SCons (S ns') = S (go sList ns') + + +-- required to prove the wrapped typelist is an instance of SListI +functorWrappedSListIsSList :: forall f xs . SListI xs=>Proxy f -> SList xs -> Dict SListI (FunctorWrapTypeList f xs) +functorWrappedSListIsSList _ SNil = Dict +functorWrappedSListIsSList pf SCons = goCons (sList :: SList xs) + where + goCons :: forall y ys . SList (y ': ys) -> Dict SListI (FunctorWrapTypeList f (y ': ys)) + goCons SCons = withDict (functorWrappedSListIsSList pf (sList :: SList ys)) Dict + + +-- NB: THe fromJust in there is safe! +-- dMapToNP has to return Maybe NP since the DMap could be incomplete. +-- But since we built this DMap from an NP, we know it's complete and dMapToNp will return a Just. +npSequenceViaDMap::forall k (f:: * -> *) (g:: * -> *) (xs::[*]).(Functor f + , SListI xs + , DM.GCompare k + , k ~ TypeListTag (FunctorWrapTypeList g xs)) + =>(DM.DMap k f -> f (DM.DMap k Identity))->NP (f :.: g) xs -> f (NP g xs) +npSequenceViaDMap sequenceDMap = + withDict (functorWrappedSListIsSList (Proxy :: Proxy g) (sList :: SList xs)) $ + fmap (hmap (runIdentity . unComp) . npReCompose . (\(Just x)->x) . dMapToNP) . sequenceDMap . npToDMap . npUnCompose diff --git a/src/Reflex/Dynamic/CollectDynGeneric.hs b/src/Reflex/Dynamic/CollectDynGeneric.hs index 6df15af3..c71be72b 100644 --- a/src/Reflex/Dynamic/CollectDynGeneric.hs +++ b/src/Reflex/Dynamic/CollectDynGeneric.hs @@ -9,6 +9,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -- only requried for copied section {-# LANGUAGE FlexibleInstances #-} -- only required for copied section +{-# LANGUAGE ExplicitNamespaces #-} {-# OPTIONS -fno-warn-unused-imports #-} {-# OPTIONS -fno-warn-unused-top-binds #-} {-| @@ -27,29 +28,13 @@ import Generics.SOP (NS, NP,SListI, SListI2, hmap,I(I),unI ,Code,SOP(..),unSOP ,hsequence',hliftA, hcliftA, Proxy(..)) - +import Generics.SOP.DMapUtilities (npReCompose,nsOfnpReCompose, npSequenceViaDMap + ,FunctorWrapTypeList,FunctorWrapTypeListOfLists) + import Reflex.Class (Reflex) -- where is the canonical, least surface area place, to get this? import Reflex.Dynamic (Dynamic,distributeDMapOverDynPure) --- these imports only for the copied section -import Generics.SOP (hmap,hcollapse,NS(..),NP(..),SListI(..) - ,SListI2,SList(..),All2,Compose - ,FieldInfo,ConstructorInfo,K(..) - , type (-.->)(Fn), (:.:)(Comp), unComp,Proxy(..)) -import Generics.SOP.NP (sequence'_NP) -import Generics.SOP.NS (ap_NS) -import Generics.SOP.Dict (Dict(Dict),withDict) - -import qualified Data.Dependent.Map as DM -import Data.Dependent.Sum (DSum ((:=>))) -import qualified Data.Dependent.Sum as DS -import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), - GOrdering (..)) - -import Data.Functor.Identity (Identity(Identity,runIdentity)) -import Data.Maybe (fromJust) --- end imports for copied section distributeNPOverDyn::(Reflex t, SListI xs)=>NP I (FunctorWrapTypeList (Dynamic t) xs) -> Dynamic t (NP I xs) distributeNPOverDyn = collectDynPureNP . hliftA (unI . unComp) . npReCompose @@ -67,114 +52,6 @@ collectDynPureNSNP = collectDynPureNP::(Reflex t, SListI xs)=>NP (Dynamic t) xs -> Dynamic t (NP I xs) collectDynPureNP = npSequenceViaDMap distributeDMapOverDynPure . hliftA (Comp . fmap I) - -{- - This is copied from perConstructor-sop until it's released. - should be replaced by an import: - -import Generics.SOP.DMapUtilities (npSequenceViaDMap,npReCompose,nsOfnpReCompose - ,FunctorWrapTypeList,FunctorWrapTypeListOfLists) --} --- |A Tag type for making DMaps of type-level lists -data TypeListTag (xs :: [k]) (x :: k) where -- x is in xs - Here :: TypeListTag (x ': xs) x -- x begins xs - There :: TypeListTag xs x -> TypeListTag (y ': xs) x -- given that x is in xs, x is also in (y ': xs) - -instance GEq (TypeListTag xs) where - geq Here Here = Just Refl - geq (There x) (There y) = geq x y - geq _ _ = Nothing - -instance GCompare (TypeListTag xs) where - gcompare Here Here = GEQ - gcompare Here (There _) = GLT - gcompare (There _) Here = GGT - gcompare (There x) (There y) = gcompare x y - - - --- |Convert an 'NP' indexed by typelist xs into a 'DM.DMap' indexed by 'TypeListTag' xs -npToDMap::NP f xs -> DM.DMap (TypeListTag xs) f -npToDMap Nil = DM.empty -npToDMap (fx :* np') = DM.insert Here fx $ DM.mapKeysMonotonic There $ npToDMap np' - --- |Convert a 'DM.DMap' indexed by 'TypeListTag' xs to an 'NP' --- |NB: This can fail since there is no guarantee that the 'DM.DMap' has entries for every tag. Hence it returns a 'Maybe' -dMapToNP::forall xs f.SListI xs=>DM.DMap (TypeListTag xs) f -> Maybe (NP f xs) -dMapToNP dm = sequence'_NP $ hmap (\tag -> Comp $ DM.lookup tag dm) makeTypeListTagNP - --- |Convert a 'NS' indexed by a typelist xs to a 'DS.DSum' indexed by 'TypeListTag' xs -nsToDSum::SListI xs=>NS f xs -> DS.DSum (TypeListTag xs) f -nsToDSum ns = - let nsFToNSDSum::SListI xs=>NS f xs -> NS (K (DS.DSum (TypeListTag xs) f)) xs - nsFToNSDSum ns' = ap_NS (tagsToFs makeTypeListTagNP) ns' - tagsToFs::SListI xs=>NP (TypeListTag xs) xs -> NP (f -.-> K (DS.DSum (TypeListTag xs) f)) xs - tagsToFs = hmap (\tag -> (Fn $ \val -> K (tag :=> val))) - in hcollapse $ nsFToNSDSum ns - --- |Convert a 'DS.DSum' indexed by 'TypeListTag' xs into a 'NS' indexed by xs -dSumToNS::SListI xs=>DS.DSum (TypeListTag xs) f -> NS f xs -dSumToNS (tag :=> fa) = go tag fa where - go::TypeListTag ys y->f y->NS f ys - go Here fy = Z fy - go (There tag') fy = S (go tag' fy) - -makeTypeListTagNP::SListI xs=>NP (TypeListTag xs) xs -makeTypeListTagNP = go sList where - go::forall ys.SListI ys=>SList ys->NP (TypeListTag ys) ys - go SNil = Nil - go SCons = Here :* hmap There (go sList) - - --- these are here to allow moving functors in and out of typelists -type family FunctorWrapTypeList (f :: * -> *) (xs :: [*]) :: [*] where - FunctorWrapTypeList f '[] = '[] - FunctorWrapTypeList f (x ': xs) = f x ': FunctorWrapTypeList f xs - -type family FunctorWrapTypeListOfLists (f :: * -> *) (xss :: [[*]]) :: [[*]] where - FunctorWrapTypeListOfLists f '[] = '[] - FunctorWrapTypeListOfLists f (xs ': xss') = FunctorWrapTypeList f xs ': FunctorWrapTypeListOfLists f xss' - -npUnCompose::forall f g xs.SListI xs=>NP (f :.: g) xs -> NP f (FunctorWrapTypeList g xs) -npUnCompose np = go np where - go::NP (f :.: g) ys -> NP f (FunctorWrapTypeList g ys) - go Nil = Nil - go (fgx :* np') = unComp fgx :* go np' - - -npReCompose::forall f g xs.SListI xs=>NP f (FunctorWrapTypeList g xs) -> NP (f :.: g) xs -- (RemoveFunctor g (AddFunctor g xs)) -npReCompose = go sList where - go::forall ys.SListI ys=>SList ys -> NP f (FunctorWrapTypeList g ys) -> NP (f :.: g) ys - go SNil Nil = Nil - go SCons (fgx :* np') = Comp fgx :* go sList np' - -nsOfnpReCompose::forall f g xss.(SListI xss, SListI2 xss)=>NS (NP f) (FunctorWrapTypeListOfLists g xss) -> NS (NP (f :.: g)) xss -nsOfnpReCompose = go sList - where - go::forall yss.(SListI2 yss, SListI yss)=>SList yss->NS (NP f) (FunctorWrapTypeListOfLists g yss) -> NS (NP (f :.: g)) yss - go SNil _ = undefined -- this shouldn't' happen since an NS can't be empty - go SCons (Z np) = Z (npReCompose np) - go SCons (S ns') = S (go sList ns') - - --- required to prove the wrapped typelist is an instance of SListI -functorWrappedSListIsSList :: forall f xs . SListI xs=>Proxy f -> SList xs -> Dict SListI (FunctorWrapTypeList f xs) -functorWrappedSListIsSList _ SNil = Dict -functorWrappedSListIsSList pf SCons = goCons (sList :: SList xs) - where - goCons :: forall y ys . SList (y ': ys) -> Dict SListI (FunctorWrapTypeList f (y ': ys)) - goCons SCons = withDict (functorWrappedSListIsSList pf (sList :: SList ys)) Dict --- NB: THe fromJust in there is safe! --- dMapToNP has to return Maybe NP since the DMap could be incomplete. --- But since we built this DMap from an NP, we know it's complete and dMapToNp will return a Just. -npSequenceViaDMap::forall k (f:: * -> *) (g:: * -> *) (xs::[*]).(Functor f - , SListI xs - , DM.GCompare k - , k ~ TypeListTag (FunctorWrapTypeList g xs)) - =>(DM.DMap k f -> f (DM.DMap k Identity))->NP (f :.: g) xs -> f (NP g xs) -npSequenceViaDMap sequenceDMap = - withDict (functorWrappedSListIsSList (Proxy :: Proxy g) (sList :: SList xs)) $ - fmap (hmap (runIdentity . unComp) . npReCompose . fromJust . dMapToNP) . sequenceDMap . npToDMap . npUnCompose --- End copied section + diff --git a/stack.yaml b/stack.yaml index a338170c..20c01339 100644 --- a/stack.yaml +++ b/stack.yaml @@ -52,7 +52,9 @@ extra-deps: - ref-tf-0.4.0.1 # Override default flag values for local packages and extra-deps -flags: {} +flags: + reflex: + use-template-haskell: true # Extra package databases containing global packages extra-package-dbs: [] diff --git a/test/Reflex/Test/TH.hs b/test/Reflex/Test/TH.hs index ffca7d2b..9bbd677d 100644 --- a/test/Reflex/Test/TH.hs +++ b/test/Reflex/Test/TH.hs @@ -13,7 +13,7 @@ testCases = testE "mkDynPure" $ do dyn1 <- holdDyn 0 =<< events1 dyn2 <- holdDyn 0 =<< events2 - let dynResult = [mkDynPure|$dyn1 + $dyn2|] + let dynResult = [mkDynPure|($dyn1, $dyn2)|] return $ updated dynResult ] where diff --git a/test/semantics.hs b/test/semantics.hs index 858c4a3f..8fc47eab 100644 --- a/test/semantics.hs +++ b/test/semantics.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} - +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} module Main (main) where import Reflex.Test @@ -39,7 +39,9 @@ main = do where allTests = concat [ makeGroup "micro" Micro.testCases +#ifdef USE_TEMPLATE_HASKELL , makeGroup "TH" TH.testCases +#endif , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40) , makeGroup "firing 1000" (Focused.firing 1000) , makeGroup "merge 100" (Focused.merging 100) From 493a720aa15aa3411e57e327fab367296130b5d1 Mon Sep 17 00:00:00 2001 From: adamConnerSax Date: Tue, 25 Apr 2017 17:19:57 -0400 Subject: [PATCH 04/11] Added deprecations for old HList/FHList stuff. Fixed lint/stylish-haskell issue. --- src/Generics/SOP/DMapUtilities.hs | 64 +++--- src/Reflex/Dynamic.hs | 279 +++++++++++++----------- src/Reflex/Dynamic/CollectDynGeneric.hs | 61 +++--- test/Reflex/Test/TH.hs | 3 +- 4 files changed, 212 insertions(+), 195 deletions(-) diff --git a/src/Generics/SOP/DMapUtilities.hs b/src/Generics/SOP/DMapUtilities.hs index 7439e1de..fbfbcde3 100644 --- a/src/Generics/SOP/DMapUtilities.hs +++ b/src/Generics/SOP/DMapUtilities.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-| Module : Generics.SOP.DMapUtilities Description : Utilities for converting between the NS/NP types of generics-sop and Dependent Maps. @@ -20,10 +21,10 @@ module Generics.SOP.DMapUtilities -- ** Add functors around types in a typelist or typelist of typelists FunctorWrapTypeList , FunctorWrapTypeListOfLists - + -- * Types , TypeListTag - + -- * Conversions -- ** NP <-> DMap , npToDMap @@ -31,35 +32,33 @@ module Generics.SOP.DMapUtilities -- ** NS <-> DSum , nsToDSum , dSumToNS - - -- * Functor wrapping/unwrapping utilities for 'NP' + + -- * Functor wrapping/unwrapping utilities for 'NP' , npUnCompose , npReCompose , nsOfnpReCompose - + -- * Utilities , npSequenceViaDMap -- * Proofs - + , functorWrappedSListIsSList )where -import Generics.SOP (hmap,hcollapse,NS(..),NP(..),SListI(..) - ,SListI2,SList(..),K(..) - , type (-.->)(Fn), (:.:)(Comp), unComp,Proxy(..)) -import Generics.SOP.NP (sequence'_NP) -import Generics.SOP.NS (ap_NS) -import Generics.SOP.Dict (Dict(Dict),withDict) +import Generics.SOP ((:.:) (Comp), K (..), NP (..), NS (..), Proxy (..), SList (..), SListI (..), SListI2, fn, + hcollapse, hmap, unComp) +import Generics.SOP.Dict (Dict (Dict), withDict) +import Generics.SOP.NP (sequence'_NP) +import Generics.SOP.NS (ap_NS) import qualified Data.Dependent.Map as DM -import Data.Dependent.Sum (DSum ((:=>))) +import Data.Dependent.Sum (DSum ((:=>))) import qualified Data.Dependent.Sum as DS -import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), - GOrdering (..)) +import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..)) -import Data.Functor.Identity (Identity(runIdentity)) +import Data.Functor.Identity (Identity (runIdentity)) -- |A Tag type for making DMaps of type-level lists @@ -90,14 +89,15 @@ npToDMap (fx :* np') = DM.insert Here fx $ DM.mapKeysMonotonic There $ npToDMap dMapToNP::forall xs f.SListI xs=>DM.DMap (TypeListTag xs) f -> Maybe (NP f xs) dMapToNP dm = sequence'_NP $ hmap (\tag -> Comp $ DM.lookup tag dm) makeTypeListTagNP --- |Convert a 'NS' indexed by a typelist xs to a 'DS.DSum' indexed by 'TypeListTag' xs +-- |Convert a 'NS' indexed by a typelist xs to a 'DS.DSum' indexed by 'TypeListTag' xs nsToDSum::SListI xs=>NS f xs -> DS.DSum (TypeListTag xs) f -nsToDSum ns = - let nsFToNSDSum::SListI xs=>NS f xs -> NS (K (DS.DSum (TypeListTag xs) f)) xs +nsToDSum = hcollapse . ap_NS (hmap (\tag -> (fn $ \val -> K (tag :=> val))) makeTypeListTagNP) +{- let nsFToNSDSum::SListI xs=>NS f xs -> NS (K (DS.DSum (TypeListTag xs) f)) xs nsFToNSDSum ns' = ap_NS (tagsToFs makeTypeListTagNP) ns' tagsToFs::SListI xs=>NP (TypeListTag xs) xs -> NP (f -.-> K (DS.DSum (TypeListTag xs) f)) xs tagsToFs = hmap (\tag -> (Fn $ \val -> K (tag :=> val))) - in hcollapse $ nsFToNSDSum ns + in hcollapse . nsFToNSDSum +-} -- |Convert a 'DS.DSum' indexed by 'TypeListTag' xs into a 'NS' indexed by xs dSumToNS::SListI xs=>DS.DSum (TypeListTag xs) f -> NS f xs @@ -123,7 +123,7 @@ type family FunctorWrapTypeListOfLists (f :: * -> *) (xss :: [[*]]) :: [[*]] whe FunctorWrapTypeListOfLists f (xs ': xss') = FunctorWrapTypeList f xs ': FunctorWrapTypeListOfLists f xss' npUnCompose::forall f g xs.SListI xs=>NP (f :.: g) xs -> NP f (FunctorWrapTypeList g xs) -npUnCompose np = go np where +npUnCompose = go where go::NP (f :.: g) ys -> NP f (FunctorWrapTypeList g ys) go Nil = Nil go (fgx :* np') = unComp fgx :* go np' @@ -155,7 +155,7 @@ functorWrappedSListIsSList pf SCons = goCons (sList :: SList xs) -- NB: THe fromJust in there is safe! -- dMapToNP has to return Maybe NP since the DMap could be incomplete. --- But since we built this DMap from an NP, we know it's complete and dMapToNp will return a Just. +-- But since we built this DMap from an NP, we know it's complete and dMapToNp will return a Just. npSequenceViaDMap::forall k (f:: * -> *) (g:: * -> *) (xs::[*]).(Functor f , SListI xs , DM.GCompare k diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index 2b5e3603..c3921478 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -287,15 +287,154 @@ demuxed d k = let e = select (demuxSelector d) (Const2 k) in unsafeBuildDynamic (fmap (==k) $ sample $ demuxValue d) e + +-------------------------------------------------------------------------------- +-- Deprecated functions +-------------------------------------------------------------------------------- + +-- | Map a function over a 'Dynamic'. +{-# DEPRECATED mapDyn "Use 'return . fmap f' instead of 'mapDyn f'; consider eliminating monadic style" #-} +mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b) +mapDyn f = return . fmap f + +-- | Map a sampling function over a 'Dynamic'. The sampling function will use the input 'Dynamic''s 'current' 'Behavior' until the first time its 'updated' 'Event' fires, at which point it will be invoked only once each time the 'Event' fires. +{-# DEPRECATED mapDynM "Consider using the Monad instance for Dynamic instead." #-} +mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b) +mapDynM f d = do + let e' = push (fmap Just . f :: a -> PushM t (Maybe b)) $ updated d + eb' = fmap constant e' + v0 = pull $ f =<< sample (current d) + bb' :: Behavior t (Behavior t b) <- hold v0 eb' + let b' = pull $ sample =<< sample bb' + return $ unsafeDynamic b' e' + +-- | Flipped version of 'mapDyn'. +{-# DEPRECATED forDyn "Use 'return . ffor a' instead of 'forDyn a'; consider eliminating monadic style" #-} +forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b) +forDyn a = return . ffor a + +-- | Flipped version of 'mapDynM' +{-# DEPRECATED forDynM "Consider using the Monad instance for Dynamic instead." #-} +forDynM :: forall t m a b. (Reflex t, MonadHold t m) => Dynamic t a -> (forall m'. MonadSample t m' => a -> m' b) -> m (Dynamic t b) +forDynM d f = mapDynM f d + +-- | Split the 'Dynamic' into two 'Dynamic's, each taking the respective value +-- of the tuple. +{-# DEPRECATED splitDyn "Use 'return . splitDynPure' instead; consider eliminating monadic style" #-} +splitDyn :: (Reflex t, Monad m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b) +splitDyn = return . splitDynPure + +-- | Merge the 'Dynamic' values using their 'Monoid' instance. +{-# DEPRECATED mconcatDyn "Use 'return . mconcat' instead; consider eliminating monadic style" #-} +mconcatDyn :: forall t m a. (Reflex t, Monad m, Monoid a) => [Dynamic t a] -> m (Dynamic t a) +mconcatDyn = return . mconcat + +-- | This function no longer needs to be monadic; see 'distributeMapOverDynPure'. +{-# DEPRECATED distributeDMapOverDyn "Use 'return . distributeDMapOverDynPure' instead; consider eliminating monadic style" #-} +distributeDMapOverDyn :: (Reflex t, Monad m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity)) +distributeDMapOverDyn = return . distributeDMapOverDynPure + +-- | Merge two 'Dynamic's into a new one using the provided function. The new +-- 'Dynamic' changes its value each time one of the original 'Dynamic's changes +-- its value. +{-# DEPRECATED combineDyn "Use 'return (zipDynWith f a b)' instead of 'combineDyn f a b'; consider eliminating monadic style" #-} +combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c) +combineDyn f a b = return $ zipDynWith f a b + +-- | A psuedo applicative version of ap for 'Dynamic'. Example useage: +-- +-- > do +-- > person <- Person `mapDyn` dynFirstName +-- > `apDyn` dynListName +-- > `apDyn` dynAge +-- > `apDyn` dynAddress +{-# DEPRECATED apDyn "Use 'ffor m (<*> a)' instead of 'apDyn m a'; consider eliminating monadic style, since Dynamics are now Applicative and can be used with applicative style directly" #-} +#ifdef USE_TEMPLATE_HASKELL +{-# ANN apDyn "HLint: ignore Use fmap" #-} +#endif +apDyn :: forall t m a b. (Reflex t, Monad m) + => m (Dynamic t (a -> b)) + -> Dynamic t a + -> m (Dynamic t b) +apDyn m a = fmap (<*> a) m + +--TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out +-- | This function no longer needs to be monadic, so it has been replaced by +-- 'demuxed', which is pure. +{-# DEPRECATED getDemuxed "Use 'return . demuxed d' instead of 'getDemuxed d'; consider eliminating monadic style" #-} +getDemuxed :: (Reflex t, Monad m, Eq k) => Demux t k -> k -> m (Dynamic t Bool) +getDemuxed d = return . demuxed d + +-- | This function no longer needs to be monadic, so it has been replaced by +-- 'distributeFHListOverDynPure', which is pure. +{-# DEPRECATED distributeFHListOverDyn "Use 'return . distributeFHListOverDynPure' instead; consider eliminating monadic style" #-} +distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l)) +distributeFHListOverDyn = return . distributeFHListOverDynPure + +-- | This function no longer needs to be monadic, so it has been replaced by +-- 'collectDynPure', which is pure. +{-# DEPRECATED collectDyn "Use 'return . collectDynPure' instead; consider eliminating monadic style" #-} +collectDyn :: ( RebuildSortedHList (HListElems b) + , IsHList a, IsHList b + , AllAreFunctors (Dynamic t) (HListElems b) + , Reflex t, Monad m + , HListElems a ~ FunctorList (Dynamic t) (HListElems b) + ) => a -> m (Dynamic t b) +collectDyn = return . collectDynPure + +-- | This function has been renamed to 'tagPromptlyDyn' to clarify its +-- semantics. +{-# DEPRECATED tagDyn "Use 'tagPromptlyDyn' instead" #-} +tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a +tagDyn = tagPromptlyDyn + +-- | This function has been renamed to 'attachPromptlyDyn' to clarify its +-- semantics. +{-# DEPRECATED attachDyn "Use 'attachPromptlyDyn' instead" #-} +attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b) +attachDyn = attachPromptlyDyn + +-- | This function has been renamed to 'attachPromptlyDynWith' to clarify its +-- semantics. +{-# DEPRECATED attachDynWith "Use 'attachPromptlyDynWith' instead" #-} +attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c +attachDynWith = attachPromptlyDynWith + +-- | This function has been renamed to 'attachPromptlyDynWithMaybe' to clarify +-- its semantics. +{-# DEPRECATED attachDynWithMaybe "Use 'attachPromptlyDynWithMaybe' instead" #-} +attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c +attachDynWithMaybe = attachPromptlyDynWithMaybe + +-- | Combine an inner and outer 'Dynamic' such that the resulting 'Dynamic''s +-- current value will always be equal to the current value's current value, and +-- will change whenever either the inner or the outer (or both) values change. +{-# DEPRECATED joinDyn "Use 'join' instead" #-} +joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a +joinDyn = join + +-- | 'nubDyn''s behavior is not quite analogous to 'nub''s behavior, so it has +-- been renamed to 'uniqDyn' +{-# DEPRECATED nubDyn "Use 'uniqDyn' instead" #-} +nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a +nubDyn = uniqDyn + + -------------------------------------------------------------------------------- -- collectDyn -------------------------------------------------------------------------------- ---TODO: This whole section is badly in need of cleanup +-- | This is now deprecated in favor of types from the generics-sop library and +-- functions provided in Reflex.Dynamic.CollectDynGeneric +-- The generics-sop 'NP' product type takes the place of FHList and HList. +-- Utilities to manipulate the NP types (shifting functors from the type into and out of the type-list +-- and convert from NP to DMap and DMap to NP are all in Generics.SOP.DMapUtilities +-- Equivalent "distribute" and "collect" functions are now in Reflex.Dynamic.CollectDynGeneric -- | A heterogeneous list whose type and length are fixed statically. This is -- reproduced from the 'HList' package due to integration issues, and because -- very little other functionality from that library is needed. +{-# 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" #-} data HList (l::[*]) where HNil :: HList '[] HCons :: e -> HList l -> HList (e ': l) @@ -328,6 +467,7 @@ instance HBuild' (a ': l) r hBuild' l x = hBuild' (HCons x l) -- | Like 'HList', but with a functor wrapping each element. +{-# DEPRECATED FHList,RebuildSortedHList "This interface for type-level lists is being deprecated in favor of the 'NP' type from generics-sop" #-} data FHList f l where FHNil :: FHList f '[] FHCons :: f e -> FHList f l -> FHList f (e ': l) @@ -345,10 +485,12 @@ instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dma HTailPtr a `gcompare` HTailPtr b = a `gcompare` b -- | A typed index into a typed heterogeneous list. +{-# DEPRECATED HListPtr "Use Generics.SOP.DMapUtiltiies.TypeListTag instead" #-} data HListPtr l a where HHeadPtr :: HListPtr (h ': t) h HTailPtr :: HListPtr t a -> HListPtr (h ': t) a +{-# DEPRECATED fhlistToDMap "Use generics-sop NP for your functor wrapped type-list and then Generics.SOP.DMapUtilities.npToDMap" #-} fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f fhlistToDMap = DMap.fromList . go where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f] @@ -378,17 +520,20 @@ instance RebuildSortedHList t => RebuildSortedHList (h ': t) where ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected" +{-# DEPRECATED dmapToHList "Use generics-sop NP for your functor wrapped type-list and then Generics.SOP.DMapUtilities.dMapToNP" #-} dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l dmapToHList = rebuildSortedHList . DMap.toList -- | Collect a hetereogeneous list whose elements are all 'Dynamic's into a -- single 'Dynamic' whose value represents the current values of all of the -- input 'Dynamic's. +{-# DEPRECATED distributeFHListOverDynPure "Use generics-sop NP types for functor-wrapped type-lists and then Reflex.Dynamic.CollectDynGeneric.collectDynPureNP " #-} distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l) distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l -- | Indicates that all elements in a type-level list are applications of the -- same functor. +{-# DEPRECATED AllAreFunctors "This functionality is provided for generics-op NPs via Generics.SOP.DMapUtilties.npUnCompose and Generics.SOP.DMapUtilities.npReCompose" #-} class AllAreFunctors (f :: a -> *) (l :: [a]) where type FunctorList f l :: [*] toFHList :: HList (FunctorList f l) -> FHList f l @@ -415,6 +560,7 @@ instance AllAreFunctors f t => AllAreFunctors f (h ': t) where -- | Convert a datastructure whose constituent parts are all 'Dynamic's into a -- single 'Dynamic' whose value represents all the current values of the input's -- consitutent 'Dynamic's. +{-# DEPRECATED collectDynPure "Use Reflex.Dynamic.CollectDynGeneric.collectDynGeneric instead." #-} collectDynPure :: ( RebuildSortedHList (HListElems b) , IsHList a, IsHList b , AllAreFunctors (Dynamic t) (HListElems b) @@ -455,134 +601,3 @@ instance IsHList (a, b, c, d, e, f) where #if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139 #endif - --------------------------------------------------------------------------------- --- Deprecated functions --------------------------------------------------------------------------------- - --- | Map a function over a 'Dynamic'. -{-# DEPRECATED mapDyn "Use 'return . fmap f' instead of 'mapDyn f'; consider eliminating monadic style" #-} -mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b) -mapDyn f = return . fmap f - --- | Map a sampling function over a 'Dynamic'. The sampling function will use the input 'Dynamic''s 'current' 'Behavior' until the first time its 'updated' 'Event' fires, at which point it will be invoked only once each time the 'Event' fires. -{-# DEPRECATED mapDynM "Consider using the Monad instance for Dynamic instead." #-} -mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b) -mapDynM f d = do - let e' = push (fmap Just . f :: a -> PushM t (Maybe b)) $ updated d - eb' = fmap constant e' - v0 = pull $ f =<< sample (current d) - bb' :: Behavior t (Behavior t b) <- hold v0 eb' - let b' = pull $ sample =<< sample bb' - return $ unsafeDynamic b' e' - --- | Flipped version of 'mapDyn'. -{-# DEPRECATED forDyn "Use 'return . ffor a' instead of 'forDyn a'; consider eliminating monadic style" #-} -forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b) -forDyn a = return . ffor a - --- | Flipped version of 'mapDynM' -{-# DEPRECATED forDynM "Consider using the Monad instance for Dynamic instead." #-} -forDynM :: forall t m a b. (Reflex t, MonadHold t m) => Dynamic t a -> (forall m'. MonadSample t m' => a -> m' b) -> m (Dynamic t b) -forDynM d f = mapDynM f d - --- | Split the 'Dynamic' into two 'Dynamic's, each taking the respective value --- of the tuple. -{-# DEPRECATED splitDyn "Use 'return . splitDynPure' instead; consider eliminating monadic style" #-} -splitDyn :: (Reflex t, Monad m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b) -splitDyn = return . splitDynPure - --- | Merge the 'Dynamic' values using their 'Monoid' instance. -{-# DEPRECATED mconcatDyn "Use 'return . mconcat' instead; consider eliminating monadic style" #-} -mconcatDyn :: forall t m a. (Reflex t, Monad m, Monoid a) => [Dynamic t a] -> m (Dynamic t a) -mconcatDyn = return . mconcat - --- | This function no longer needs to be monadic; see 'distributeMapOverDynPure'. -{-# DEPRECATED distributeDMapOverDyn "Use 'return . distributeDMapOverDynPure' instead; consider eliminating monadic style" #-} -distributeDMapOverDyn :: (Reflex t, Monad m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity)) -distributeDMapOverDyn = return . distributeDMapOverDynPure - --- | Merge two 'Dynamic's into a new one using the provided function. The new --- 'Dynamic' changes its value each time one of the original 'Dynamic's changes --- its value. -{-# DEPRECATED combineDyn "Use 'return (zipDynWith f a b)' instead of 'combineDyn f a b'; consider eliminating monadic style" #-} -combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c) -combineDyn f a b = return $ zipDynWith f a b - --- | A psuedo applicative version of ap for 'Dynamic'. Example useage: --- --- > do --- > person <- Person `mapDyn` dynFirstName --- > `apDyn` dynListName --- > `apDyn` dynAge --- > `apDyn` dynAddress -{-# DEPRECATED apDyn "Use 'ffor m (<*> a)' instead of 'apDyn m a'; consider eliminating monadic style, since Dynamics are now Applicative and can be used with applicative style directly" #-} -#ifdef USE_TEMPLATE_HASKELL -{-# ANN apDyn "HLint: ignore Use fmap" #-} -#endif -apDyn :: forall t m a b. (Reflex t, Monad m) - => m (Dynamic t (a -> b)) - -> Dynamic t a - -> m (Dynamic t b) -apDyn m a = fmap (<*> a) m - ---TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out --- | This function no longer needs to be monadic, so it has been replaced by --- 'demuxed', which is pure. -{-# DEPRECATED getDemuxed "Use 'return . demuxed d' instead of 'getDemuxed d'; consider eliminating monadic style" #-} -getDemuxed :: (Reflex t, Monad m, Eq k) => Demux t k -> k -> m (Dynamic t Bool) -getDemuxed d = return . demuxed d - --- | This function no longer needs to be monadic, so it has been replaced by --- 'distributeFHListOverDynPure', which is pure. -{-# DEPRECATED distributeFHListOverDyn "Use 'return . distributeFHListOverDynPure' instead; consider eliminating monadic style" #-} -distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l)) -distributeFHListOverDyn = return . distributeFHListOverDynPure - --- | This function no longer needs to be monadic, so it has been replaced by --- 'collectDynPure', which is pure. -{-# DEPRECATED collectDyn "Use 'return . collectDynPure' instead; consider eliminating monadic style" #-} -collectDyn :: ( RebuildSortedHList (HListElems b) - , IsHList a, IsHList b - , AllAreFunctors (Dynamic t) (HListElems b) - , Reflex t, Monad m - , HListElems a ~ FunctorList (Dynamic t) (HListElems b) - ) => a -> m (Dynamic t b) -collectDyn = return . collectDynPure - --- | This function has been renamed to 'tagPromptlyDyn' to clarify its --- semantics. -{-# DEPRECATED tagDyn "Use 'tagPromptlyDyn' instead" #-} -tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a -tagDyn = tagPromptlyDyn - --- | This function has been renamed to 'attachPromptlyDyn' to clarify its --- semantics. -{-# DEPRECATED attachDyn "Use 'attachPromptlyDyn' instead" #-} -attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b) -attachDyn = attachPromptlyDyn - --- | This function has been renamed to 'attachPromptlyDynWith' to clarify its --- semantics. -{-# DEPRECATED attachDynWith "Use 'attachPromptlyDynWith' instead" #-} -attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c -attachDynWith = attachPromptlyDynWith - --- | This function has been renamed to 'attachPromptlyDynWithMaybe' to clarify --- its semantics. -{-# DEPRECATED attachDynWithMaybe "Use 'attachPromptlyDynWithMaybe' instead" #-} -attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c -attachDynWithMaybe = attachPromptlyDynWithMaybe - --- | Combine an inner and outer 'Dynamic' such that the resulting 'Dynamic''s --- current value will always be equal to the current value's current value, and --- will change whenever either the inner or the outer (or both) values change. -{-# DEPRECATED joinDyn "Use 'join' instead" #-} -joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a -joinDyn = join - --- | 'nubDyn''s behavior is not quite analogous to 'nub''s behavior, so it has --- been renamed to 'uniqDyn' -{-# DEPRECATED nubDyn "Use 'uniqDyn' instead" #-} -nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a -nubDyn = uniqDyn diff --git a/src/Reflex/Dynamic/CollectDynGeneric.hs b/src/Reflex/Dynamic/CollectDynGeneric.hs index c71be72b..adfb77ac 100644 --- a/src/Reflex/Dynamic/CollectDynGeneric.hs +++ b/src/Reflex/Dynamic/CollectDynGeneric.hs @@ -1,17 +1,15 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -- only requried for copied section -{-# LANGUAGE FlexibleInstances #-} -- only required for copied section -{-# LANGUAGE ExplicitNamespaces #-} -{-# OPTIONS -fno-warn-unused-imports #-} -{-# OPTIONS -fno-warn-unused-top-binds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-| Module: Reflex.Dynamic.CollectDynGeneric Description: Generic (generics-sop) implementation of CollectDynPure and distributeFHListOverDynPure @@ -23,25 +21,31 @@ module Reflex.Dynamic.CollectDynGeneric , collectDynPureNP ) where -import Generics.SOP (NS, NP,SListI, SListI2, hmap,I(I),unI - , (:.:)(Comp),unComp,from,to, Generic - ,Code,SOP(..),unSOP - ,hsequence',hliftA, hcliftA, Proxy(..)) - -import Generics.SOP.DMapUtilities (npReCompose,nsOfnpReCompose, npSequenceViaDMap - ,FunctorWrapTypeList,FunctorWrapTypeListOfLists) - -import Reflex.Class (Reflex) -- where is the canonical, least surface area place, to get this? -import Reflex.Dynamic (Dynamic,distributeDMapOverDynPure) +import Generics.SOP ((:.:) (Comp), Code, Generic, I (I), NP, NS, Proxy (..), SListI, SListI2, SOP (..), from, + hcliftA, hliftA, hmap, hsequence', to, unComp, unI, unSOP) +import Generics.SOP.DMapUtilities (FunctorWrapTypeList, FunctorWrapTypeListOfLists, npReCompose, + npSequenceViaDMap, nsOfnpReCompose) +import Reflex.Class (Reflex) +import Reflex.Dynamic (Dynamic, distributeDMapOverDynPure) -distributeNPOverDyn::(Reflex t, SListI xs)=>NP I (FunctorWrapTypeList (Dynamic t) xs) -> Dynamic t (NP I xs) -distributeNPOverDyn = collectDynPureNP . hliftA (unI . unComp) . npReCompose +-- | Take a type-list indexed product of dynamics and produce a dynamic of a type-list of values (wrapped by an Identity functor, I). +collectDynPureNP::(Reflex t, SListI xs)=>NP (Dynamic t) xs -> Dynamic t (NP I xs) +collectDynPureNP = npSequenceViaDMap distributeDMapOverDynPure . hliftA (Comp . fmap I) + +-- | Given a pair of types a and b where a is like b except each field of each constructor is dynamic +-- (e.g., (Dynamic t x, Dynamic t y) and (x,y) or Either (Dynamic t x) (Dynamic t y) and Either x y) +-- convert the former into a Dynamic of the latter. collectDynGeneric::(Reflex t,Generic a, Generic b, (Code a) ~ FunctorWrapTypeListOfLists (Dynamic t) (Code b))=>a -> Dynamic t b collectDynGeneric = fmap (to . SOP) . hsequence' . collectDynPureNSNP . aToNSNPI +-- | A variation on collectDynPureNP which more closely mirrors the structure of distributeFHlistOverDynPure +distributeNPOverDyn::(Reflex t, SListI xs)=>NP I (FunctorWrapTypeList (Dynamic t) xs) -> Dynamic t (NP I xs) +distributeNPOverDyn = collectDynPureNP . hliftA (unI . unComp) . npReCompose + + aToNSNPI::(Generic a, Code a ~ FunctorWrapTypeListOfLists (Dynamic t) xss, SListI2 xss) =>a -> NS (NP (I :.: Dynamic t)) xss aToNSNPI = nsOfnpReCompose . unSOP . from @@ -50,8 +54,7 @@ collectDynPureNSNP = let slistIC = Proxy :: Proxy SListI in hcliftA slistIC (Comp . collectDynPureNP . hliftA (unI . unComp)) -collectDynPureNP::(Reflex t, SListI xs)=>NP (Dynamic t) xs -> Dynamic t (NP I xs) -collectDynPureNP = npSequenceViaDMap distributeDMapOverDynPure . hliftA (Comp . fmap I) - + + diff --git a/test/Reflex/Test/TH.hs b/test/Reflex/Test/TH.hs index 9bbd677d..e7d09da7 100644 --- a/test/Reflex/Test/TH.hs +++ b/test/Reflex/Test/TH.hs @@ -3,7 +3,6 @@ module Reflex.Test.TH (testCases) where import Reflex -import Reflex.Dynamic.TH import Reflex.TestPlan @@ -13,7 +12,7 @@ testCases = testE "mkDynPure" $ do dyn1 <- holdDyn 0 =<< events1 dyn2 <- holdDyn 0 =<< events2 - let dynResult = [mkDynPure|($dyn1, $dyn2)|] + let dynResult = [mkDynPure|$dyn1 + $dyn2|] return $ updated dynResult ] where From a8ee06d07f9cc2f335f3041c864892f1390507b9 Mon Sep 17 00:00:00 2001 From: adamConnerSax Date: Tue, 25 Apr 2017 17:28:46 -0400 Subject: [PATCH 05/11] Edited some other deprecations. --- src/Reflex/Dynamic.hs | 4 ++-- test/Reflex/Test/TH.hs | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index c3921478..784bb109 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -367,13 +367,13 @@ getDemuxed d = return . demuxed d -- | This function no longer needs to be monadic, so it has been replaced by -- 'distributeFHListOverDynPure', which is pure. -{-# DEPRECATED distributeFHListOverDyn "Use 'return . distributeFHListOverDynPure' instead; consider eliminating monadic style" #-} +{-# DEPRECATED distributeFHListOverDyn "Use functions provided in Reflex.Dynamic.CollectDynGeneric; consider eliminating monadic style" #-} distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l)) distributeFHListOverDyn = return . distributeFHListOverDynPure -- | This function no longer needs to be monadic, so it has been replaced by -- 'collectDynPure', which is pure. -{-# DEPRECATED collectDyn "Use 'return . collectDynPure' instead; consider eliminating monadic style" #-} +{-# DEPRECATED collectDyn "Use return . Reflex.Dynamic.CollectDynGeneric.collectDynGeneric instead; consider eliminating monadic style." #-} collectDyn :: ( RebuildSortedHList (HListElems b) , IsHList a, IsHList b , AllAreFunctors (Dynamic t) (HListElems b) diff --git a/test/Reflex/Test/TH.hs b/test/Reflex/Test/TH.hs index e7d09da7..4dce07ab 100644 --- a/test/Reflex/Test/TH.hs +++ b/test/Reflex/Test/TH.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE GADTs #-} module Reflex.Test.TH (testCases) where import Reflex From 30173f566c5abd58c26ad3cbe1ae7c6fcf8c0b38 Mon Sep 17 00:00:00 2001 From: adamConnerSax Date: Wed, 26 Apr 2017 00:46:42 -0400 Subject: [PATCH 06/11] Added a separate mkDynPure test in Pure reflex only . --- reflex.cabal | 12 +++++++++ src/Reflex/Dynamic/CollectDynGeneric.hs | 2 +- test/MkDyn.hs | 36 +++++++++++++++++++++++++ test/semantics.hs | 17 ++++++------ 4 files changed, 58 insertions(+), 9 deletions(-) create mode 100644 test/MkDyn.hs diff --git a/reflex.cabal b/reflex.cabal index 90a946eb..e1aa6aee 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -195,6 +195,18 @@ test-suite rootCleanup build-depends: base , reflex +test-suite mkDyn + type: exitcode-stdio-1.0 + main-is: MkDyn.hs + hs-source-dirs: test + if !flag(use-template-haskell) + buildable: False + build-depends: base + , reflex + , deepseq + , mtl + , containers + benchmark spider-bench type: exitcode-stdio-1.0 hs-source-dirs: bench diff --git a/src/Reflex/Dynamic/CollectDynGeneric.hs b/src/Reflex/Dynamic/CollectDynGeneric.hs index adfb77ac..db44b2eb 100644 --- a/src/Reflex/Dynamic/CollectDynGeneric.hs +++ b/src/Reflex/Dynamic/CollectDynGeneric.hs @@ -22,7 +22,7 @@ module Reflex.Dynamic.CollectDynGeneric ) where import Generics.SOP ((:.:) (Comp), Code, Generic, I (I), NP, NS, Proxy (..), SListI, SListI2, SOP (..), from, - hcliftA, hliftA, hmap, hsequence', to, unComp, unI, unSOP) + hcliftA, hliftA, hsequence', to, unComp, unI, unSOP) import Generics.SOP.DMapUtilities (FunctorWrapTypeList, FunctorWrapTypeListOfLists, npReCompose, npSequenceViaDMap, nsOfnpReCompose) diff --git a/test/MkDyn.hs b/test/MkDyn.hs new file mode 100644 index 00000000..81071564 --- /dev/null +++ b/test/MkDyn.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +module Main where + +import Data.IntMap +import Reflex +import Reflex.Dynamic.TH +import Reflex.Plan.Pure +import Reflex.TestPlan +import System.Exit + +main::IO () +main = do + let setup = do + pEv1 <- planList [1.0,2.0,3.0] + pEv2 <- planList [-1.0,-2.0,-3.0] + dyn1 <- holdDyn 0 pEv1 + dyn2 <- holdDyn 0 pEv2 + return (dyn1, dyn2) + resMkDyn :: IntMap (Maybe Double) + resMkDyn = testEvent $ runPure $ do + (dyn1, dyn2) <- setup + let dynFromMkDyn = [mkDynPure|$dyn1 + $dyn2|] + return $ updated dynFromMkDyn + resZipDyn :: IntMap (Maybe Double) + resZipDyn = testEvent $ runPure $ do + (dyn1,dyn2) <- setup + let dynFromZipDyn = zipDynWith (+) dyn1 dyn2 + return $ updated dynFromZipDyn + testPassed = resMkDyn == resZipDyn + putStrLn $ "MkDynPure: " ++ show resMkDyn + putStrLn $ "zipDynWith: " ++ show resZipDyn + exitWith $ if testPassed then ExitSuccess else ExitFailure 1 + + diff --git a/test/semantics.hs b/test/semantics.hs index 8fc47eab..e78fa9f7 100644 --- a/test/semantics.hs +++ b/test/semantics.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} module Main (main) where import Reflex.Test @@ -14,8 +14,9 @@ import Data.Functor import Data.List import qualified Reflex.Bench.Focused as Focused import qualified Reflex.Test.Micro as Micro +#ifdef USE_TEMPLATE_HASKELL import qualified Reflex.Test.TH as TH - +#endif import System.Environment import System.Exit @@ -39,7 +40,7 @@ main = do where allTests = concat [ makeGroup "micro" Micro.testCases -#ifdef USE_TEMPLATE_HASKELL +#ifdef USE_TEMPLATE_HASKELL , makeGroup "TH" TH.testCases #endif , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40) From b14a13383e783fc54e7e64eccb3bcfde3db454f1 Mon Sep 17 00:00:00 2001 From: adamConnerSax Date: Wed, 26 Apr 2017 12:19:54 -0400 Subject: [PATCH 07/11] Removed 'Pure' from names of new functions. Added some hyperlink quotes to comments and deprecations. Verified that the MkDyn test can fail. Added log output of success or failure. --- src/Generics/SOP/DMapUtilities.hs | 6 +++--- src/Reflex/Dynamic.hs | 12 ++++++------ src/Reflex/Dynamic/CollectDynGeneric.hs | 22 +++++++++++----------- src/Reflex/Dynamic/TH.hs | 8 +++----- test/MkDyn.hs | 2 ++ 5 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/Generics/SOP/DMapUtilities.hs b/src/Generics/SOP/DMapUtilities.hs index fbfbcde3..53515c78 100644 --- a/src/Generics/SOP/DMapUtilities.hs +++ b/src/Generics/SOP/DMapUtilities.hs @@ -61,7 +61,7 @@ import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..)) import Data.Functor.Identity (Identity (runIdentity)) --- |A Tag type for making DMaps of type-level lists +-- |A Tag type for making a 'DM.DMap' keyed by a type-level list data TypeListTag (xs :: [k]) (x :: k) where -- x is in xs Here :: TypeListTag (x ': xs) x -- x begins xs There :: TypeListTag xs x -> TypeListTag (y ': xs) x -- given that x is in xs, x is also in (y ': xs) @@ -139,7 +139,7 @@ nsOfnpReCompose::forall f g xss.(SListI xss, SListI2 xss)=>NS (NP f) (FunctorWra nsOfnpReCompose = go sList where go::forall yss.(SListI2 yss, SListI yss)=>SList yss->NS (NP f) (FunctorWrapTypeListOfLists g yss) -> NS (NP (f :.: g)) yss - go SNil _ = undefined -- this shouldn't' happen since an NS can't be empty + go SNil _ = undefined -- this shouldn't happen since an NS can't be empty go SCons (Z np) = Z (npReCompose np) go SCons (S ns') = S (go sList ns') @@ -153,7 +153,7 @@ functorWrappedSListIsSList pf SCons = goCons (sList :: SList xs) goCons SCons = withDict (functorWrappedSListIsSList pf (sList :: SList ys)) Dict --- NB: THe fromJust in there is safe! +-- NB: The (\(Just x)->x) in there is safe! -- dMapToNP has to return Maybe NP since the DMap could be incomplete. -- But since we built this DMap from an NP, we know it's complete and dMapToNp will return a Just. npSequenceViaDMap::forall k (f:: * -> *) (g:: * -> *) (xs::[*]).(Functor f diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index 784bb109..1397cf29 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -485,12 +485,12 @@ instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dma HTailPtr a `gcompare` HTailPtr b = a `gcompare` b -- | A typed index into a typed heterogeneous list. -{-# DEPRECATED HListPtr "Use Generics.SOP.DMapUtiltiies.TypeListTag instead" #-} +{-# DEPRECATED HListPtr "Use 'Generics.SOP.DMapUtiltiies.TypeListTag' instead" #-} data HListPtr l a where HHeadPtr :: HListPtr (h ': t) h HTailPtr :: HListPtr t a -> HListPtr (h ': t) a -{-# DEPRECATED fhlistToDMap "Use generics-sop NP for your functor wrapped type-list and then Generics.SOP.DMapUtilities.npToDMap" #-} +{-# DEPRECATED fhlistToDMap "Use generics-sop 'NP' for your functor wrapped type-list and then 'Generics.SOP.DMapUtilities.npToDMap'" #-} fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f fhlistToDMap = DMap.fromList . go where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f] @@ -520,20 +520,20 @@ instance RebuildSortedHList t => RebuildSortedHList (h ': t) where ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected" -{-# DEPRECATED dmapToHList "Use generics-sop NP for your functor wrapped type-list and then Generics.SOP.DMapUtilities.dMapToNP" #-} +{-# DEPRECATED dmapToHList "Use generics-sop 'NP' for your functor wrapped type-list and then 'Generics.SOP.DMapUtilities.dMapToNP'" #-} dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l dmapToHList = rebuildSortedHList . DMap.toList -- | Collect a hetereogeneous list whose elements are all 'Dynamic's into a -- single 'Dynamic' whose value represents the current values of all of the -- input 'Dynamic's. -{-# DEPRECATED distributeFHListOverDynPure "Use generics-sop NP types for functor-wrapped type-lists and then Reflex.Dynamic.CollectDynGeneric.collectDynPureNP " #-} +{-# DEPRECATED distributeFHListOverDynPure "Use the generics-sop 'NP' type for functor-wrapped type-lists and then 'Reflex.Dynamic.CollectDynGeneric.collectDynNP' " #-} distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l) distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l -- | Indicates that all elements in a type-level list are applications of the -- same functor. -{-# DEPRECATED AllAreFunctors "This functionality is provided for generics-op NPs via Generics.SOP.DMapUtilties.npUnCompose and Generics.SOP.DMapUtilities.npReCompose" #-} +{-# DEPRECATED AllAreFunctors "This functionality is provided for generics-sop 'NP' via 'Generics.SOP.DMapUtilties.npUnCompose' and 'Generics.SOP.DMapUtilities.npReCompose'" #-} class AllAreFunctors (f :: a -> *) (l :: [a]) where type FunctorList f l :: [*] toFHList :: HList (FunctorList f l) -> FHList f l @@ -560,7 +560,7 @@ instance AllAreFunctors f t => AllAreFunctors f (h ': t) where -- | Convert a datastructure whose constituent parts are all 'Dynamic's into a -- single 'Dynamic' whose value represents all the current values of the input's -- consitutent 'Dynamic's. -{-# DEPRECATED collectDynPure "Use Reflex.Dynamic.CollectDynGeneric.collectDynGeneric instead." #-} +{-# DEPRECATED collectDynPure "Use 'Reflex.Dynamic.CollectDynGeneric.collectDynGeneric' instead." #-} collectDynPure :: ( RebuildSortedHList (HListElems b) , IsHList a, IsHList b , AllAreFunctors (Dynamic t) (HListElems b) diff --git a/src/Reflex/Dynamic/CollectDynGeneric.hs b/src/Reflex/Dynamic/CollectDynGeneric.hs index db44b2eb..e7095f7a 100644 --- a/src/Reflex/Dynamic/CollectDynGeneric.hs +++ b/src/Reflex/Dynamic/CollectDynGeneric.hs @@ -18,7 +18,7 @@ module Reflex.Dynamic.CollectDynGeneric ( distributeNPOverDyn , collectDynGeneric - , collectDynPureNP + , collectDynNP ) where import Generics.SOP ((:.:) (Comp), Code, Generic, I (I), NP, NS, Proxy (..), SListI, SListI2, SOP (..), from, @@ -31,28 +31,28 @@ import Reflex.Class (Reflex) import Reflex.Dynamic (Dynamic, distributeDMapOverDynPure) --- | Take a type-list indexed product of dynamics and produce a dynamic of a type-list of values (wrapped by an Identity functor, I). -collectDynPureNP::(Reflex t, SListI xs)=>NP (Dynamic t) xs -> Dynamic t (NP I xs) -collectDynPureNP = npSequenceViaDMap distributeDMapOverDynPure . hliftA (Comp . fmap I) +-- | 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'). +collectDynNP::(Reflex t, SListI xs)=>NP (Dynamic t) xs -> Dynamic t (NP I xs) +collectDynNP = npSequenceViaDMap distributeDMapOverDynPure . hliftA (Comp . fmap I) -- | Given a pair of types a and b where a is like b except each field of each constructor is dynamic --- (e.g., (Dynamic t x, Dynamic t y) and (x,y) or Either (Dynamic t x) (Dynamic t y) and Either x y) +-- (e.g., ('Dynamic' t x, 'Dynamic' t y) and (x,y) or Either ('Dynamic' t x) ('Dynamic' t y) and Either x y) -- convert the former into a Dynamic of the latter. collectDynGeneric::(Reflex t,Generic a, Generic b, (Code a) ~ FunctorWrapTypeListOfLists (Dynamic t) (Code b))=>a -> Dynamic t b -collectDynGeneric = fmap (to . SOP) . hsequence' . collectDynPureNSNP . aToNSNPI +collectDynGeneric = fmap (to . SOP) . hsequence' . collectDynNSNP . aToNSNPI --- | A variation on collectDynPureNP which more closely mirrors the structure of distributeFHlistOverDynPure +-- | A variation on 'collectDynPureNP' which more closely mirrors the structure of (deprecated) 'Reflex.Dynamic.distributeFHlistOverDynPure' distributeNPOverDyn::(Reflex t, SListI xs)=>NP I (FunctorWrapTypeList (Dynamic t) xs) -> Dynamic t (NP I xs) -distributeNPOverDyn = collectDynPureNP . hliftA (unI . unComp) . npReCompose +distributeNPOverDyn = collectDynNP . hliftA (unI . unComp) . npReCompose aToNSNPI::(Generic a, Code a ~ FunctorWrapTypeListOfLists (Dynamic t) xss, SListI2 xss) =>a -> NS (NP (I :.: Dynamic t)) xss aToNSNPI = nsOfnpReCompose . unSOP . from -collectDynPureNSNP::(Reflex t,SListI2 xss)=>NS (NP (I :.: Dynamic t)) xss -> NS (Dynamic t :.: NP I) xss -collectDynPureNSNP = +collectDynNSNP::(Reflex t,SListI2 xss)=>NS (NP (I :.: Dynamic t)) xss -> NS (Dynamic t :.: NP I) xss +collectDynNSNP = let slistIC = Proxy :: Proxy SListI - in hcliftA slistIC (Comp . collectDynPureNP . hliftA (unI . unComp)) + in hcliftA slistIC (Comp . collectDynNP . hliftA (unI . unComp)) diff --git a/src/Reflex/Dynamic/TH.hs b/src/Reflex/Dynamic/TH.hs index fb838d5f..ff24c703 100644 --- a/src/Reflex/Dynamic/TH.hs +++ b/src/Reflex/Dynamic/TH.hs @@ -18,10 +18,8 @@ module Reflex.Dynamic.TH , mkDyn ) where -import Reflex.Dynamic - -import Reflex.Dynamic.CollectDynGeneric -import Generics.SOP (NP(..),I(..)) +import Generics.SOP (I (..), NP (..)) +import Reflex.Dynamic.CollectDynGeneric (collectDynNP) import Control.Monad.State import Data.Data @@ -52,7 +50,7 @@ qDynPure qe = do let exprs = reverse exprsReversed arg = foldr (\a b -> ConE '(:*) `AppE` a `AppE` b) (ConE 'Nil) $ map snd exprs param = foldr (\a b -> ConP '(:*) [ConP 'I [VarP a], b]) (ConP 'Nil []) $ map fst exprs - [| $(return $ LamE [param] e') <$> collectDynPureNP $(return arg) |] + [| $(return $ LamE [param] e') <$> collectDynNP $(return arg) |] -- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a diff --git a/test/MkDyn.hs b/test/MkDyn.hs index 81071564..b8bae919 100644 --- a/test/MkDyn.hs +++ b/test/MkDyn.hs @@ -31,6 +31,8 @@ main = do testPassed = resMkDyn == resZipDyn putStrLn $ "MkDynPure: " ++ show resMkDyn putStrLn $ "zipDynWith: " ++ show resZipDyn + putStr "MkDyn: " + if testPassed then putStrLn "Succeeded" else putStrLn "Failed" exitWith $ if testPassed then ExitSuccess else ExitFailure 1 From f22feb26d30814590a63e36f1f681cd5b8204614 Mon Sep 17 00:00:00 2001 From: adamConnerSax Date: Wed, 26 Apr 2017 13:34:46 -0400 Subject: [PATCH 08/11] Much documentation re-working. --- src/Generics/SOP/DMapUtilities.hs | 32 +++++++++++++++---------- src/Reflex/Dynamic.hs | 19 ++++++++------- src/Reflex/Dynamic/CollectDynGeneric.hs | 15 +++++++----- 3 files changed, 39 insertions(+), 27 deletions(-) diff --git a/src/Generics/SOP/DMapUtilities.hs b/src/Generics/SOP/DMapUtilities.hs index 53515c78..28a1fb03 100644 --- a/src/Generics/SOP/DMapUtilities.hs +++ b/src/Generics/SOP/DMapUtilities.hs @@ -18,7 +18,6 @@ Description : Utilities for converting between the NS/NP types of generics- module Generics.SOP.DMapUtilities ( -- * Type Functions - -- ** Add functors around types in a typelist or typelist of typelists FunctorWrapTypeList , FunctorWrapTypeListOfLists @@ -26,10 +25,10 @@ module Generics.SOP.DMapUtilities , TypeListTag -- * Conversions - -- ** NP <-> DMap + -- ** 'NP' \<-\> 'DM.DMap' , npToDMap , dMapToNP - -- ** NS <-> DSum + -- ** 'NS' \<-\> 'DSum' , nsToDSum , dSumToNS @@ -40,8 +39,8 @@ module Generics.SOP.DMapUtilities -- * Utilities , npSequenceViaDMap - -- * Proofs + -- * Proofs , functorWrappedSListIsSList )where @@ -77,8 +76,6 @@ instance GCompare (TypeListTag xs) where gcompare (There _) Here = GGT gcompare (There x) (There y) = gcompare x y - - -- |Convert an 'NP' indexed by typelist xs into a 'DM.DMap' indexed by 'TypeListTag' xs npToDMap::NP f xs -> DM.DMap (TypeListTag xs) f npToDMap Nil = DM.empty @@ -122,6 +119,10 @@ type family FunctorWrapTypeListOfLists (f :: * -> *) (xss :: [[*]]) :: [[*]] whe FunctorWrapTypeListOfLists f '[] = '[] FunctorWrapTypeListOfLists f (xs ': xss') = FunctorWrapTypeList f xs ': FunctorWrapTypeListOfLists f xss' +-- | 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 +-- 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., +-- +-- > (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] npUnCompose::forall f g xs.SListI xs=>NP (f :.: g) xs -> NP f (FunctorWrapTypeList g xs) npUnCompose = go where go::NP (f :.: g) ys -> NP f (FunctorWrapTypeList g ys) @@ -129,12 +130,16 @@ npUnCompose = go where go (fgx :* np') = unComp fgx :* go np' -npReCompose::forall f g xs.SListI xs=>NP f (FunctorWrapTypeList g xs) -> NP (f :.: g) xs -- (RemoveFunctor g (AddFunctor g xs)) +-- | The inverse of 'npUnCompose'. Given a type-list indexed product where all the types in the list are applications of the same functor, +-- 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 +-- to types representing composition of the functors. +npReCompose::forall f g xs.SListI xs=>NP f (FunctorWrapTypeList g xs) -> NP (f :.: g) xs npReCompose = go sList where go::forall ys.SListI ys=>SList ys -> NP f (FunctorWrapTypeList g ys) -> NP (f :.: g) ys go SNil Nil = Nil go SCons (fgx :* np') = Comp fgx :* go sList np' +-- | ReCompose all the 'NP's in an "NS (NP f) xss". nsOfnpReCompose::forall f g xss.(SListI xss, SListI2 xss)=>NS (NP f) (FunctorWrapTypeListOfLists g xss) -> NS (NP (f :.: g)) xss nsOfnpReCompose = go sList where @@ -143,8 +148,7 @@ nsOfnpReCompose = go sList go SCons (Z np) = Z (npReCompose np) go SCons (S ns') = S (go sList ns') - --- required to prove the wrapped typelist is an instance of SListI +-- | Prove that "SListI xs=>(FunctorWrapTypeList f xs)" is also an instance of SListI functorWrappedSListIsSList :: forall f xs . SListI xs=>Proxy f -> SList xs -> Dict SListI (FunctorWrapTypeList f xs) functorWrappedSListIsSList _ SNil = Dict functorWrappedSListIsSList pf SCons = goCons (sList :: SList xs) @@ -153,9 +157,10 @@ functorWrappedSListIsSList pf SCons = goCons (sList :: SList xs) goCons SCons = withDict (functorWrappedSListIsSList pf (sList :: SList ys)) Dict --- NB: The (\(Just x)->x) in there is safe! --- dMapToNP has to return Maybe NP since the DMap could be incomplete. --- But since we built this DMap from an NP, we know it's complete and dMapToNp will return a Just. + +-- | sequence (in the sense of 'Data.Traversable.sequenceA') a functor f inside an 'NP' using a function defined over a 'DM.DMap' indexed by the same type-level-list. +-- This is useful in cases where an efficient general solution exists for DMaps. +-- This can be done more simply for Applicative f but the efficiency will depend on the particular functor and given function over 'DM.DMap'. npSequenceViaDMap::forall k (f:: * -> *) (g:: * -> *) (xs::[*]).(Functor f , SListI xs , DM.GCompare k @@ -164,3 +169,6 @@ npSequenceViaDMap::forall k (f:: * -> *) (g:: * -> *) (xs::[*]).(Functor f npSequenceViaDMap sequenceDMap = withDict (functorWrappedSListIsSList (Proxy :: Proxy g) (sList :: SList xs)) $ fmap (hmap (runIdentity . unComp) . npReCompose . (\(Just x)->x) . dMapToNP) . sequenceDMap . npToDMap . npUnCompose +-- NB: The (\(Just x)->x) in there is safe! +-- dMapToNP has to return Maybe NP since the DMap could be incomplete. +-- But since we built this DMap from an NP, we know it's complete and dMapToNp will return a Just. diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index 1397cf29..ebbf8966 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -47,15 +47,6 @@ module Reflex.Dynamic , Demux , demux , demuxed - -- Things that probably aren't very useful: - , HList (..) - , FHList (..) - , collectDynPure - , RebuildSortedHList (..) - , IsHList (..) - , AllAreFunctors (..) - , HListPtr (..) - , distributeFHListOverDynPure -- Unsafe , unsafeDynamic -- * Deprecated functions @@ -77,6 +68,16 @@ module Reflex.Dynamic , nubDyn , splitDyn , tagDyn + -- Things that probably aren't very useful, and are also deprecated + , HList (..) + , FHList (..) + , collectDynPure + , RebuildSortedHList (..) + , IsHList (..) + , AllAreFunctors (..) + , HListPtr (..) + , distributeFHListOverDynPure + ) where import Prelude hiding (mapM, mapM_) diff --git a/src/Reflex/Dynamic/CollectDynGeneric.hs b/src/Reflex/Dynamic/CollectDynGeneric.hs index e7095f7a..6838fe32 100644 --- a/src/Reflex/Dynamic/CollectDynGeneric.hs +++ b/src/Reflex/Dynamic/CollectDynGeneric.hs @@ -16,9 +16,9 @@ Description: Generic (generics-sop) implementation of CollectDynPure and distrib -} module Reflex.Dynamic.CollectDynGeneric ( - distributeNPOverDyn - , collectDynGeneric + collectDynGeneric , collectDynNP + , distributeNPOverDyn ) where import Generics.SOP ((:.:) (Comp), Code, Generic, I (I), NP, NS, Proxy (..), SListI, SListI2, SOP (..), from, @@ -35,13 +35,16 @@ import Reflex.Dynamic (Dynamic, distributeDMapOverDynPure) collectDynNP::(Reflex t, SListI xs)=>NP (Dynamic t) xs -> Dynamic t (NP I xs) collectDynNP = npSequenceViaDMap distributeDMapOverDynPure . hliftA (Comp . fmap I) --- | Given a pair of types a and b where a is like b except each field of each constructor is dynamic --- (e.g., ('Dynamic' t x, 'Dynamic' t y) and (x,y) or Either ('Dynamic' t x) ('Dynamic' t y) and Either x y) --- convert the former into a Dynamic of the latter. +-- | 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') +-- and where a is "like" b except each field of each constructor is a Dynamic, +-- convert the former into a Dynamic of the latter. E.g., +-- +-- > (Dynamic t x, Dynamic t y) -> Dynamic t (x,y) +-- > Either (Dynamic t x) (Dynamic t y) -> Dynamic t (Either x y) collectDynGeneric::(Reflex t,Generic a, Generic b, (Code a) ~ FunctorWrapTypeListOfLists (Dynamic t) (Code b))=>a -> Dynamic t b collectDynGeneric = fmap (to . SOP) . hsequence' . collectDynNSNP . aToNSNPI --- | A variation on 'collectDynPureNP' which more closely mirrors the structure of (deprecated) 'Reflex.Dynamic.distributeFHlistOverDynPure' +-- | A variation on 'collectDynNP' which more closely mirrors the structure of (deprecated) 'Reflex.Dynamic.distributeFHlistOverDynPure' distributeNPOverDyn::(Reflex t, SListI xs)=>NP I (FunctorWrapTypeList (Dynamic t) xs) -> Dynamic t (NP I xs) distributeNPOverDyn = collectDynNP . hliftA (unI . unComp) . npReCompose From 076a3bd9db0b8502127988cce130189503f50e91 Mon Sep 17 00:00:00 2001 From: adamConnerSax Date: Sun, 30 Apr 2017 10:25:41 -0400 Subject: [PATCH 09/11] Renamed TypeListTag constructors from Here and There to TLHead and TLTail. Reformatted code more in-line with rest of codebase. Removed stack.yaml. Added comments/haddocks for all top-level functions. --- src/Generics/SOP/DMapUtilities.hs | 113 ++++++++++++------------ src/Reflex/Dynamic/CollectDynGeneric.hs | 17 ++-- stack.yaml | 78 ---------------- 3 files changed, 66 insertions(+), 142 deletions(-) delete mode 100644 stack.yaml diff --git a/src/Generics/SOP/DMapUtilities.hs b/src/Generics/SOP/DMapUtilities.hs index 28a1fb03..434ff109 100644 --- a/src/Generics/SOP/DMapUtilities.hs +++ b/src/Generics/SOP/DMapUtilities.hs @@ -56,38 +56,36 @@ import qualified Data.Dependent.Sum as DS import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..)) - import Data.Functor.Identity (Identity (runIdentity)) - -- |A Tag type for making a 'DM.DMap' keyed by a type-level list data TypeListTag (xs :: [k]) (x :: k) where -- x is in xs - Here :: TypeListTag (x ': xs) x -- x begins xs - There :: TypeListTag xs x -> TypeListTag (y ': xs) x -- given that x is in xs, x is also in (y ': xs) + TLHead :: TypeListTag (x ': xs) x -- x begins xs + TLTail :: TypeListTag xs x -> TypeListTag (y ': xs) x -- given that x is in xs, x is also in (y ': xs) instance GEq (TypeListTag xs) where - geq Here Here = Just Refl - geq (There x) (There y) = geq x y - geq _ _ = Nothing + geq TLHead TLHead = Just Refl + geq (TLTail x) (TLTail y) = geq x y + geq _ _ = Nothing instance GCompare (TypeListTag xs) where - gcompare Here Here = GEQ - gcompare Here (There _) = GLT - gcompare (There _) Here = GGT - gcompare (There x) (There y) = gcompare x y + gcompare TLHead TLHead = GEQ + gcompare TLHead (TLTail _) = GLT + gcompare (TLTail _) TLHead = GGT + gcompare (TLTail x) (TLTail y) = gcompare x y -- |Convert an 'NP' indexed by typelist xs into a 'DM.DMap' indexed by 'TypeListTag' xs -npToDMap::NP f xs -> DM.DMap (TypeListTag xs) f +npToDMap :: NP f xs -> DM.DMap (TypeListTag xs) f npToDMap Nil = DM.empty -npToDMap (fx :* np') = DM.insert Here fx $ DM.mapKeysMonotonic There $ npToDMap np' +npToDMap (fx :* npTail) = DM.insert TLHead fx $ DM.mapKeysMonotonic TLTail $ npToDMap npTail -- |Convert a 'DM.DMap' indexed by 'TypeListTag' xs to an 'NP' -- |NB: This can fail since there is no guarantee that the 'DM.DMap' has entries for every tag. Hence it returns a 'Maybe' -dMapToNP::forall xs f.SListI xs=>DM.DMap (TypeListTag xs) f -> Maybe (NP f xs) -dMapToNP dm = sequence'_NP $ hmap (\tag -> Comp $ DM.lookup tag dm) makeTypeListTagNP +dMapToNP :: forall xs f. SListI xs => DM.DMap (TypeListTag xs) f -> Maybe (NP f xs) +dMapToNP dm = sequence'_NP $ hmap (Comp . flip DM.lookup dm) makeTypeListTagNP -- |Convert a 'NS' indexed by a typelist xs to a 'DS.DSum' indexed by 'TypeListTag' xs -nsToDSum::SListI xs=>NS f xs -> DS.DSum (TypeListTag xs) f +nsToDSum :: SListI xs => NS f xs -> DS.DSum (TypeListTag xs) f nsToDSum = hcollapse . ap_NS (hmap (\tag -> (fn $ \val -> K (tag :=> val))) makeTypeListTagNP) {- let nsFToNSDSum::SListI xs=>NS f xs -> NS (K (DS.DSum (TypeListTag xs) f)) xs nsFToNSDSum ns' = ap_NS (tagsToFs makeTypeListTagNP) ns' @@ -97,18 +95,20 @@ nsToDSum = hcollapse . ap_NS (hmap (\tag -> (fn $ \val -> K (tag :=> val))) make -} -- |Convert a 'DS.DSum' indexed by 'TypeListTag' xs into a 'NS' indexed by xs -dSumToNS::SListI xs=>DS.DSum (TypeListTag xs) f -> NS f xs -dSumToNS (tag :=> fa) = go tag fa where - go::TypeListTag ys y->f y->NS f ys - go Here fy = Z fy - go (There tag') fy = S (go tag' fy) - -makeTypeListTagNP::SListI xs=>NP (TypeListTag xs) xs -makeTypeListTagNP = go sList where - go::forall ys.SListI ys=>SList ys->NP (TypeListTag ys) ys - go SNil = Nil - go SCons = Here :* hmap There (go sList) +dSumToNS :: SListI xs => DS.DSum (TypeListTag xs) f -> NS f xs +dSumToNS (tag :=> fa) = go tag fa + where + go::TypeListTag ys y -> f y -> NS f ys + go TLHead fy = Z fy + go (TLTail nextTag) fy = S $ go nextTag fy +-- | Produce an NP of TypeListTags matching the type-list of the NP +makeTypeListTagNP :: SListI xs => NP (TypeListTag xs) xs +makeTypeListTagNP = go sList + where + go :: forall ys. SListI ys => SList ys -> NP (TypeListTag ys) ys + go SNil = Nil + go SCons = TLHead :* hmap TLTail (go sList) -- these are here to allow moving functors in and out of typelists type family FunctorWrapTypeList (f :: * -> *) (xs :: [*]) :: [*] where @@ -117,58 +117,59 @@ type family FunctorWrapTypeList (f :: * -> *) (xs :: [*]) :: [*] where type family FunctorWrapTypeListOfLists (f :: * -> *) (xss :: [[*]]) :: [[*]] where FunctorWrapTypeListOfLists f '[] = '[] - FunctorWrapTypeListOfLists f (xs ': xss') = FunctorWrapTypeList f xs ': FunctorWrapTypeListOfLists f xss' + FunctorWrapTypeListOfLists f (xs ': xsTail) = FunctorWrapTypeList f xs ': FunctorWrapTypeListOfLists f xsTail -- | 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 -- 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., -- -- > (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] -npUnCompose::forall f g xs.SListI xs=>NP (f :.: g) xs -> NP f (FunctorWrapTypeList g xs) -npUnCompose = go where - go::NP (f :.: g) ys -> NP f (FunctorWrapTypeList g ys) - go Nil = Nil - go (fgx :* np') = unComp fgx :* go np' - +npUnCompose :: forall f g xs. SListI xs => NP (f :.: g) xs -> NP f (FunctorWrapTypeList g xs) +npUnCompose = go + where + go :: NP (f :.: g) ys -> NP f (FunctorWrapTypeList g ys) + go Nil = Nil + go (fgx :* npTail) = unComp fgx :* go npTail -- | The inverse of 'npUnCompose'. Given a type-list indexed product where all the types in the list are applications of the same functor, -- 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 -- to types representing composition of the functors. -npReCompose::forall f g xs.SListI xs=>NP f (FunctorWrapTypeList g xs) -> NP (f :.: g) xs -npReCompose = go sList where - go::forall ys.SListI ys=>SList ys -> NP f (FunctorWrapTypeList g ys) -> NP (f :.: g) ys - go SNil Nil = Nil - go SCons (fgx :* np') = Comp fgx :* go sList np' +npReCompose :: forall f g xs. SListI xs => NP f (FunctorWrapTypeList g xs) -> NP (f :.: g) xs +npReCompose = go sList + where + go::forall ys. SListI ys => SList ys -> NP f (FunctorWrapTypeList g ys) -> NP (f :.: g) ys + go SNil Nil = Nil + go SCons (fgx :* npTail) = Comp fgx :* go sList npTail -- | ReCompose all the 'NP's in an "NS (NP f) xss". -nsOfnpReCompose::forall f g xss.(SListI xss, SListI2 xss)=>NS (NP f) (FunctorWrapTypeListOfLists g xss) -> NS (NP (f :.: g)) xss +nsOfnpReCompose :: forall f g xss. (SListI xss, SListI2 xss) => NS (NP f) (FunctorWrapTypeListOfLists g xss) -> NS (NP (f :.: g)) xss nsOfnpReCompose = go sList where - go::forall yss.(SListI2 yss, SListI yss)=>SList yss->NS (NP f) (FunctorWrapTypeListOfLists g yss) -> NS (NP (f :.: g)) yss - go SNil _ = undefined -- this shouldn't happen since an NS can't be empty - go SCons (Z np) = Z (npReCompose np) - go SCons (S ns') = S (go sList ns') + go :: forall yss. (SListI2 yss, SListI yss) => SList yss -> NS (NP f) (FunctorWrapTypeListOfLists g yss) -> NS (NP (f :.: g)) yss + go SNil _ = error "NS must be non-empty." -- this shouldn't happen since an NS can't be empty + go SCons (Z np) = Z $ npReCompose np + go SCons (S nsTail) = S $ go sList nsTail -- | Prove that "SListI xs=>(FunctorWrapTypeList f xs)" is also an instance of SListI -functorWrappedSListIsSList :: forall f xs . SListI xs=>Proxy f -> SList xs -> Dict SListI (FunctorWrapTypeList f xs) +functorWrappedSListIsSList :: forall f xs. SListI xs => Proxy f -> SList xs -> Dict SListI (FunctorWrapTypeList f xs) functorWrappedSListIsSList _ SNil = Dict functorWrappedSListIsSList pf SCons = goCons (sList :: SList xs) where - goCons :: forall y ys . SList (y ': ys) -> Dict SListI (FunctorWrapTypeList f (y ': ys)) - goCons SCons = withDict (functorWrappedSListIsSList pf (sList :: SList ys)) Dict - - + goCons :: forall y ys. SList (y ': ys) -> Dict SListI (FunctorWrapTypeList f (y ': ys)) + goCons SCons = + let dict = functorWrappedSListIsSList pf $ (sList :: SList ys) + in withDict dict Dict --- | sequence (in the sense of 'Data.Traversable.sequenceA') a functor f inside an 'NP' using a function defined over a 'DM.DMap' indexed by the same type-level-list. +-- | sequence (in the sense of 'Data.Traversable.sequenceA') a functor f inside an 'NP' +-- using a function defined over a 'DM.DMap' indexed by the same type-level-list. -- This is useful in cases where an efficient general solution exists for DMaps. --- This can be done more simply for Applicative f but the efficiency will depend on the particular functor and given function over 'DM.DMap'. -npSequenceViaDMap::forall k (f:: * -> *) (g:: * -> *) (xs::[*]).(Functor f - , SListI xs - , DM.GCompare k - , k ~ TypeListTag (FunctorWrapTypeList g xs)) +-- This can be done more simply for Applicative f but the efficiency will depend on +-- the particular functor and given function over 'DM.DMap'. +npSequenceViaDMap :: forall k (f :: * -> *) (g :: * -> *) (xs :: [*]). (Functor f, SListI xs, DM.GCompare k + , k ~ TypeListTag (FunctorWrapTypeList g xs)) =>(DM.DMap k f -> f (DM.DMap k Identity))->NP (f :.: g) xs -> f (NP g xs) npSequenceViaDMap sequenceDMap = withDict (functorWrappedSListIsSList (Proxy :: Proxy g) (sList :: SList xs)) $ - fmap (hmap (runIdentity . unComp) . npReCompose . (\(Just x)->x) . dMapToNP) . sequenceDMap . npToDMap . npUnCompose + fmap (hmap (runIdentity . unComp) . npReCompose . (\(Just x) -> x) . dMapToNP) . sequenceDMap . npToDMap . npUnCompose -- NB: The (\(Just x)->x) in there is safe! -- dMapToNP has to return Maybe NP since the DMap could be incomplete. -- But since we built this DMap from an NP, we know it's complete and dMapToNp will return a Just. diff --git a/src/Reflex/Dynamic/CollectDynGeneric.hs b/src/Reflex/Dynamic/CollectDynGeneric.hs index 6838fe32..080bb977 100644 --- a/src/Reflex/Dynamic/CollectDynGeneric.hs +++ b/src/Reflex/Dynamic/CollectDynGeneric.hs @@ -30,9 +30,8 @@ import Generics.SOP.DMapUtilities (FunctorWrapTypeList, FunctorWrapTypeListOfLis import Reflex.Class (Reflex) import Reflex.Dynamic (Dynamic, distributeDMapOverDynPure) - -- | 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'). -collectDynNP::(Reflex t, SListI xs)=>NP (Dynamic t) xs -> Dynamic t (NP I xs) +collectDynNP :: (Reflex t, SListI xs) => NP (Dynamic t) xs -> Dynamic t (NP I xs) collectDynNP = npSequenceViaDMap distributeDMapOverDynPure . hliftA (Comp . fmap I) -- | 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') @@ -41,21 +40,23 @@ collectDynNP = npSequenceViaDMap distributeDMapOverDynPure . hliftA (Comp . fmap -- -- > (Dynamic t x, Dynamic t y) -> Dynamic t (x,y) -- > Either (Dynamic t x) (Dynamic t y) -> Dynamic t (Either x y) -collectDynGeneric::(Reflex t,Generic a, Generic b, (Code a) ~ FunctorWrapTypeListOfLists (Dynamic t) (Code b))=>a -> Dynamic t b +collectDynGeneric :: (Reflex t, Generic a, Generic b, (Code a) ~ FunctorWrapTypeListOfLists (Dynamic t) (Code b)) => a -> Dynamic t b collectDynGeneric = fmap (to . SOP) . hsequence' . collectDynNSNP . aToNSNPI -- | A variation on 'collectDynNP' which more closely mirrors the structure of (deprecated) 'Reflex.Dynamic.distributeFHlistOverDynPure' -distributeNPOverDyn::(Reflex t, SListI xs)=>NP I (FunctorWrapTypeList (Dynamic t) xs) -> Dynamic t (NP I xs) +distributeNPOverDyn :: (Reflex t, SListI xs) => NP I (FunctorWrapTypeList (Dynamic t) xs) -> Dynamic t (NP I xs) distributeNPOverDyn = collectDynNP . hliftA (unI . unComp) . npReCompose - -aToNSNPI::(Generic a, Code a ~ FunctorWrapTypeListOfLists (Dynamic t) xss, SListI2 xss) =>a -> NS (NP (I :.: Dynamic t)) xss +-- | Utility to help simplify collectDynGeneric: Take a generic type, a, which is Dynamic in every field and make an NS of an NP +aToNSNPI :: (Generic a, Code a ~ FunctorWrapTypeListOfLists (Dynamic t) xss, SListI2 xss) => a -> NS (NP (I :.: Dynamic t)) xss aToNSNPI = nsOfnpReCompose . unSOP . from -collectDynNSNP::(Reflex t,SListI2 xss)=>NS (NP (I :.: Dynamic t)) xss -> NS (Dynamic t :.: NP I) xss +-- | Utility to help simplify collectDynGeneric: Take an NS of an NP of Dynamic fields and collect (or sequence) +-- the Dynamics from fields to constructors +collectDynNSNP :: (Reflex t, SListI2 xss) => NS (NP (I :.: Dynamic t)) xss -> NS (Dynamic t :.: NP I) xss collectDynNSNP = let slistIC = Proxy :: Proxy SListI - in hcliftA slistIC (Comp . collectDynNP . hliftA (unI . unComp)) + in hcliftA slistIC $ Comp . collectDynNP . hliftA (unI . unComp) diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index 20c01339..00000000 --- a/stack.yaml +++ /dev/null @@ -1,78 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# http://docs.haskellstack.org/en/stable/yaml_configuration/ - -# A warning or info to be displayed to the user on config load. -user-message: ! 'Warning (added by new or init): Specified resolver could not satisfy - all dependencies. Some external packages have been added as dependencies. - - You can suppress this message by removing it from stack.yaml - -' - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: lts-8.11 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. -packages: -- '.' -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -extra-deps: -- prim-uniq-0.1.0.1 -- ref-tf-0.4.0.1 - -# Override default flag values for local packages and extra-deps -flags: - reflex: - use-template-haskell: true - -# Extra package databases containing global packages -extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.4" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file From c806b0bd320da385fbe95221ab2f59b898ce2715 Mon Sep 17 00:00:00 2001 From: adamConnerSax Date: Wed, 3 May 2017 17:34:14 -0400 Subject: [PATCH 10/11] Added Reflex.Dynamic.FactorDynGeneric and Generics.SOP.Distribute. --- reflex.cabal | 6 +- src/Generics/SOP/DMapUtilities.hs | 11 ++- src/Generics/SOP/Distribute.hs | 117 +++++++++++++++++++++++++ src/Reflex/Dynamic/FactorDynGeneric.hs | 90 +++++++++++++++++++ stack.yaml | 78 +++++++++++++++++ 5 files changed, 299 insertions(+), 3 deletions(-) create mode 100644 src/Generics/SOP/Distribute.hs create mode 100644 src/Reflex/Dynamic/FactorDynGeneric.hs create mode 100644 stack.yaml diff --git a/reflex.cabal b/reflex.cabal index e1aa6aee..994945d3 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -67,13 +67,15 @@ library exposed-modules: Data.Functor.Misc, Data.WeakBag, - Generics.SOP.DMapUtilities, + Generics.SOP.DMapUtilities, + Generics.SOP.Distribute, Reflex, Reflex.Class, Reflex.EventWriter, Reflex.Dynamic, Reflex.Dynamic.Uniq, - Reflex.Dynamic.CollectDynGeneric + Reflex.Dynamic.CollectDynGeneric + Reflex.Dynamic.FactorDynGeneric Reflex.DynamicWriter, Reflex.FunctorMaybe, Reflex.Host.Class, diff --git a/src/Generics/SOP/DMapUtilities.hs b/src/Generics/SOP/DMapUtilities.hs index 434ff109..d757d7cc 100644 --- a/src/Generics/SOP/DMapUtilities.hs +++ b/src/Generics/SOP/DMapUtilities.hs @@ -34,6 +34,7 @@ module Generics.SOP.DMapUtilities -- * Functor wrapping/unwrapping utilities for 'NP' , npUnCompose + , nsOfnpUnCompose , npReCompose , nsOfnpReCompose @@ -130,13 +131,21 @@ npUnCompose = go go Nil = Nil go (fgx :* npTail) = unComp fgx :* go npTail +-- | UnCompose all of the 'NP's in an "NS (NP f) xss". +nsOfnpUnCompose :: forall f g xss. (SListI xss, SListI2 xss) => NS (NP (f :.: g)) xss -> NS (NP f) (FunctorWrapTypeListOfLists g xss) +nsOfnpUnCompose = go sList where + go :: forall yss. (SListI yss, SListI2 yss) => SList yss -> NS (NP (f :.: g)) yss -> NS (NP f) (FunctorWrapTypeListOfLists g yss) + go SNil _ = error "An NS cannot be empty" + go SCons (Z np) = Z (npUnCompose np) + go SCons (S ns') = S (go sList ns') + -- | The inverse of 'npUnCompose'. Given a type-list indexed product where all the types in the list are applications of the same functor, -- 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 -- to types representing composition of the functors. npReCompose :: forall f g xs. SListI xs => NP f (FunctorWrapTypeList g xs) -> NP (f :.: g) xs npReCompose = go sList where - go::forall ys. SListI ys => SList ys -> NP f (FunctorWrapTypeList g ys) -> NP (f :.: g) ys + go :: forall ys. SListI ys => SList ys -> NP f (FunctorWrapTypeList g ys) -> NP (f :.: g) ys go SNil Nil = Nil go SCons (fgx :* npTail) = Comp fgx :* go sList npTail diff --git a/src/Generics/SOP/Distribute.hs b/src/Generics/SOP/Distribute.hs new file mode 100644 index 00000000..37c1798d --- /dev/null +++ b/src/Generics/SOP/Distribute.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Generics.SOP.Distribute + ( + expand + , expandA + , WrappedProjection + , wrappedProjections + , shiftWrappedProjection + , WrappedInjection + , wrappedInjections + , shiftWrappedInjection + , distributeNP + , distributeI_NP + , functorToNP + , reAssociateNP + , distributeToFields + , reconstructA + , functionPOPFromClass + , Dict + ) where + +import Generics.SOP hiding (Compose) +import Generics.SOP.Dict (Dict, withDict) + +-- | Turn a sum into a product with Maybes +expand :: forall (f :: [k] -> *) xs. (SListI xs) => NS f xs -> NP (Maybe :.: f) xs +expand ns = go sList (Just ns) where + go :: forall ys.SListI ys => SList ys -> Maybe (NS f ys) -> NP (Maybe :.: f) ys + go SNil _ = Nil + go SCons mNS = case mNS of + Nothing -> Comp Nothing :* go sList Nothing -- after Z + Just ms -> case ms of + Z fx -> Comp (Just fx) :* go sList Nothing -- at Z + S ms' -> Comp Nothing :* go sList (Just ms') -- before Z + +-- | expand applied to a generics-sop generic type +expandA :: Generic a => a -> NP (Maybe :.: NP I) (Code a) +expandA = expand . unSOP . from + +-- | The type of projections from functor-wrapped values +type WrappedProjection (g :: * -> *) (f :: k -> *) (xs :: [k]) = K (g (NP f xs)) -.-> g :.: f + +-- | Create wrapped projections for a specific typelist xs +wrappedProjections :: forall xs g f. (Functor g,SListI xs) => NP (WrappedProjection g f xs) xs +wrappedProjections = case sList :: SList xs of + SNil -> Nil + SCons -> fn (Comp . fmap hd . unK) :* hliftA shiftWrappedProjection wrappedProjections + +-- | Utility for creating the product of WrappedProjections +shiftWrappedProjection :: Functor g => WrappedProjection g f xs a -> WrappedProjection g f (x ': xs) a +shiftWrappedProjection (Fn f) = Fn $ f . K . fmap tl . unK + +type WrappedInjection (g :: * -> *) (f :: k -> *) (xs :: [k]) = g :.: f -.-> K (g (NS f xs)) + +wrappedInjections :: forall xs g f. (Functor g, SListI xs) => NP (WrappedInjection g f xs) xs +wrappedInjections = case sList :: SList xs of + SNil -> Nil + SCons -> fn (K . fmap Z . unComp) :* hliftA shiftWrappedInjection wrappedInjections + +shiftWrappedInjection :: Functor g => WrappedInjection g f xs a -> WrappedInjection g f (x ': xs) a +shiftWrappedInjection (Fn f) = Fn $ K . fmap S . unK . f + +-- | distribute a functor h from outside a product into each field in the product. +-- +-- NB: For applicative h, this is an inverse of hsequence. If h is not applicative, then this is not invertible. +distributeNP :: (Functor h, SListI xs) => h (NP g xs) -> NP (h :.: g) xs +distributeNP x = hap wrappedProjections (hpure $ K x) + +-- | A special case of distribute when the product is parameterized over the identity +distributeI_NP :: (Functor h, SListI xs) => h (NP I xs) -> NP h xs +distributeI_NP = hmap (fmap unI . unComp) . distributeNP + +-- | Turn a functor wrapped value into a product of functor wrapped Maybes of products +-- with the outer product over constructors and the inner over fields +functorToNP :: forall g a.(Functor g,Generic a)=>g a -> NP (g :.: (Maybe :.: NP I)) (Code a) +functorToNP ga = hap wrappedProjections (hpure $ K (expandA <$> ga)) + +-- | utility for manipulating functors in NPs +reAssociate :: Functor g => (g :.: (f :.: h)) a -> ((g :.: f) :.: h) a +reAssociate = Comp . Comp . fmap unComp . unComp + +-- | utility for manipulating functors in NPs +reAssociateNP :: (Functor g, SListI xss) => NP (g :.: (f :.: h)) xss->NP ((g :.: f) :.: h) xss +reAssociateNP = hmap reAssociate + +-- | Apply dsitributeI_NP to all constructors of an NS of an NP +distributeToFields :: (Functor g, SListI2 xss) => NP ((g :.: Maybe) :.: NP I) xss -> POP (g :.: Maybe) xss +distributeToFields = + let proxyC = Proxy :: Proxy SListI + in POP . hcliftA proxyC (distributeI_NP . unComp) + +-- | reconstruct the per constructor, functor wrapped value from an NP of (Maybe :.: NP) +reconstructA :: (Functor h, Generic a) => NP (h :.: NP I) (Code a) -> NP (K (h a)) (Code a) +reconstructA = hliftA (K . fmap (to . SOP) . unK) . hap wrappedInjections + +-- | Utility for turning a constraint into a POP (an NP of NP) of natural transformations at a given type. +functionPOPFromClass :: forall c f g xss. SListI2 xss => Dict (All2 c) xss->(forall a.c a=>f a -> g a)->POP (f -.-> g) xss +functionPOPFromClass d fn = withDict d $ hcpure (Proxy :: Proxy c) $ Fn fn + +{- +functionPOPFromClass'::forall c f g xss.(All2 c xss, SListI2 xss)=>(forall a.c a=>f a -> g a)->POP (f -.-> g) xss +functionPOPFromClass' fn = + let dict :: Dict (All2 c) xss + dict = all_POP hdicts + in withDict dict $ hcpure (Proxy :: Proxy c) $ Fn fn +-} + + diff --git a/src/Reflex/Dynamic/FactorDynGeneric.hs b/src/Reflex/Dynamic/FactorDynGeneric.hs new file mode 100644 index 00000000..4e87cee5 --- /dev/null +++ b/src/Reflex/Dynamic/FactorDynGeneric.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +module Reflex.Dynamic.FactorDynGeneric + ( + factorDyn + , factorDynGeneric + ) where + +import Control.Monad.Fix (MonadFix) +import Data.Dependent.Sum (DSum ((:=>))) +import Data.Functor.Compose (Compose (Compose), getCompose) +import Data.GADT.Compare ((:~:) (Refl), GEq, geq) +import Data.Maybe (isJust) +import Reflex (Dynamic, Event, MonadHold, Reflex, current, ffor, fforMaybe, fmapMaybe, hold, holdDyn, never, + push, sample, switch, updated) + +import Generics.SOP ((:.:) (Comp), Code, Generic, I (I), Proxy (Proxy), SListI, SOP (SOP), from, hcmap, hmap, + to, unSOP) +import Generics.SOP.Distribute (distributeI_NP) +import Generics.SOP.DMapUtilities (FunctorWrapTypeListOfLists, dSumToNS, nsOfnpUnCompose, nsToDSum) + +-- | Use factorDyn and generics-sop to turn a Dynamic of a type into a factored Dynamic of a type with Dynamic fields. See below functions for examples +factorDynGeneric :: forall t m a b. (Reflex t, MonadFix m, MonadHold t m + , Generic a, Generic b + , (Code b) ~ FunctorWrapTypeListOfLists (Dynamic t) (Code a)) + => Dynamic t a -> m (Dynamic t b) +factorDynGeneric da = do + let dSumDyn = nsToDSum . unSOP . from <$> da -- Dynamic t (DSum (TypeListTag (Code a)) (NP I xs)) + dSumDyn' <- factorDyn dSumDyn -- Dynamic t (DSum (TypeListTag (Code a)) (NP I)) + let nsnpDyn = dSumToNS <$> dSumDyn' -- Dynamic t (NS (Compose (Dynamic t) (NP I)) (Code a)) + sListIC = Proxy :: Proxy SListI + nsnpDyn' = hcmap sListIC (hmap (Comp. I) . distributeI_NP . getCompose) <$> nsnpDyn -- Dynamic t (NS (NP (I :.: Dynamic t)) (Code a)) + nsnpDyn'' = nsOfnpUnCompose <$> nsnpDyn' -- Dynamic t (NS (NP I) (Code b)) + result = to . SOP <$> nsnpDyn'' + return result + +-- for example: +maybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe (Dynamic t a))) +maybeDyn = factorDynGeneric + +eitherDyn :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Either a b) -> m (Dynamic t (Either (Dynamic t a) (Dynamic t b))) +eitherDyn = factorDynGeneric + +takeWhileE :: forall t m a. (Reflex t, MonadFix m, MonadHold t m) => (a -> Bool) -> Event t a -> m (Event t a) +takeWhileE f e = do + rec be <- hold e $ fforMaybe e' $ \a -> if f a + then Just never + else Nothing + let e' = switch be + return e' + +--TODO: Is this a good name? I'm not sure this really resembles factorization +factorDyn :: forall t m k (v :: [*] -> *). (Reflex t, MonadFix m, MonadHold t m, GEq k) => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v))) +factorDyn d = do + k0 :=> (v0 :: v a) <- sample $ current d + let inner :: forall m' a. (MonadFix m', MonadHold t m') => k a -> v a -> m' (Dynamic t (v a)) + inner k v0 = holdDyn v0 . fmapMaybe id =<< takeWhileE isJust newVal + where newVal = ffor (updated d) $ \(newK :=> newV) -> case newK `geq` k of + Just Refl -> Just newV + Nothing -> Nothing + inner0 :: Dynamic t (v a) <- inner k0 v0 + rec result <- holdDyn (k0 :=> Compose inner0) $ flip push (updated d) $ \(newKey :=> newVal) -> do + (oldKey :=> _) <- sample $ current d + case newKey `geq` oldKey of + Just Refl -> return Nothing + Nothing -> do + newInner <- inner newKey newVal + return $ Just $ newKey :=> Compose newInner + return result + + +{- +maybeDyn :: forall t a m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe (Dynamic t a))) +maybeDyn d = do + ma <- sample $ current d + let inner :: forall m'. (MonadFix m', MonadHold t m') => a -> m' (Dynamic t a) + inner a = holdDyn a . fmapMaybe id =<< takeWhileE isJust (updated d) + mInner0 :: Maybe (Dynamic t a) <- mapM inner ma + rec result <- holdDyn mInner0 $ flip push (updated d) $ \new -> do + old <- sample $ current d + if isJust old == isJust new then return Nothing else Just <$> mapM inner new + return result +-} + + diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 00000000..20c01339 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,78 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# http://docs.haskellstack.org/en/stable/yaml_configuration/ + +# A warning or info to be displayed to the user on config load. +user-message: ! 'Warning (added by new or init): Specified resolver could not satisfy + all dependencies. Some external packages have been added as dependencies. + + You can suppress this message by removing it from stack.yaml + +' + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-8.11 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- '.' +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: +- prim-uniq-0.1.0.1 +- ref-tf-0.4.0.1 + +# Override default flag values for local packages and extra-deps +flags: + reflex: + use-template-haskell: true + +# Extra package databases containing global packages +extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.4" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor \ No newline at end of file From 173c1bf983b8a61b17c932230ee3757c0e154add Mon Sep 17 00:00:00 2001 From: adamConnerSax Date: Wed, 3 May 2017 17:34:28 -0400 Subject: [PATCH 11/11] Added Reflex.Dynamic.FactorDynGeneric and Generics.SOP.Distribute. --- stack.yaml | 78 ------------------------------------------------------ 1 file changed, 78 deletions(-) delete mode 100644 stack.yaml diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index 20c01339..00000000 --- a/stack.yaml +++ /dev/null @@ -1,78 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# http://docs.haskellstack.org/en/stable/yaml_configuration/ - -# A warning or info to be displayed to the user on config load. -user-message: ! 'Warning (added by new or init): Specified resolver could not satisfy - all dependencies. Some external packages have been added as dependencies. - - You can suppress this message by removing it from stack.yaml - -' - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# resolver: ghcjs-0.1.0_ghc-7.10.2 -# resolver: -# name: custom-snapshot -# location: "./custom-snapshot.yaml" -resolver: lts-8.11 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# extra-dep: true -# subdirs: -# - auto-update -# - wai -# -# A package marked 'extra-dep: true' will only be built if demanded by a -# non-dependency (i.e. a user package), and its test suites and benchmarks -# will not be run. This is useful for tweaking upstream packages. -packages: -- '.' -# Dependency packages to be pulled from upstream that are not in the resolver -# (e.g., acme-missiles-0.3) -extra-deps: -- prim-uniq-0.1.0.1 -- ref-tf-0.4.0.1 - -# Override default flag values for local packages and extra-deps -flags: - reflex: - use-template-haskell: true - -# Extra package databases containing global packages -extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.4" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor \ No newline at end of file