Replace and deprecate HList, FHList, distributeFHListOverDynPure and collectDynPure.

.gitignore

@@ -36,3 +36,4 @@ hsenv.log
 /ghci-tmp
 *.dump-*
 *.verbose-core2core
+.stack-work/*

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
   ]);

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,
@@ -66,11 +67,15 @@ library
   exposed-modules:
     Data.Functor.Misc,
     Data.WeakBag,
+    Generics.SOP.DMapUtilities,
+    Generics.SOP.Distribute,                        
     Reflex,
     Reflex.Class,
     Reflex.EventWriter,
     Reflex.Dynamic,
     Reflex.Dynamic.Uniq,
+    Reflex.Dynamic.CollectDynGeneric
+    Reflex.Dynamic.FactorDynGeneric                            
     Reflex.DynamicWriter,
     Reflex.FunctorMaybe,
     Reflex.Host.Class,
@@ -85,7 +90,7 @@ library
     Reflex.Requester.Class,
     Reflex.Spider,
     Reflex.Spider.Internal
-
+    
   ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
   ghc-prof-options: -fprof-auto
 
@@ -125,6 +130,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,
@@ -190,6 +197,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

src/Generics/SOP/DMapUtilities.hs

@@ -0,0 +1,184 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# 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.
+-}
+
+module Generics.SOP.DMapUtilities
+  (
+    -- * Type Functions
+    FunctorWrapTypeList
+  , FunctorWrapTypeListOfLists
+
+    -- * Types
+  , TypeListTag
+
+    -- * Conversions
+    -- ** 'NP' \<-\> 'DM.DMap'
+  , npToDMap
+  , dMapToNP
+    -- ** 'NS' \<-\> 'DSum'
+  , nsToDSum
+  , dSumToNS
+
+  -- * Functor wrapping/unwrapping utilities for 'NP'
+  , npUnCompose
+  , nsOfnpUnCompose
+  , npReCompose
+  , nsOfnpReCompose
+
+  -- * Utilities
+  , npSequenceViaDMap
+
+  -- * Proofs
+  , functorWrappedSListIsSList
+  )where
+
+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 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
+  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 TLHead TLHead = Just Refl
+  geq (TLTail x) (TLTail y) = geq x y
+  geq _ _  = Nothing
+
+instance GCompare (TypeListTag xs) where
+  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 Nil = DM.empty
+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 (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 = 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
+-}
+
+-- |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 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
+  FunctorWrapTypeList f '[] = '[]
+  FunctorWrapTypeList f (x ': xs) = f x ': FunctorWrapTypeList f xs
+
+type family FunctorWrapTypeListOfLists (f :: * -> *) (xss :: [[*]]) :: [[*]] where
+  FunctorWrapTypeListOfLists f '[] = '[]
+  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 :* 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 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 = 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 _ = 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 _ 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 =
+      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.
+-- 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))
+  =>(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
+-- 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.

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
+-}
+
+