{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#ifdef USE_REFLEX_OPTIMIZER
{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
#endif
-- |
-- Module:
--   Reflex.Dynamic
-- Description:
--   This module contains various functions for working with 'Dynamic' values.
--   'Dynamic' and its primitives have been moved to the 'Reflex' class.
module Reflex.Dynamic
  ( -- * Basics
    Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update
  , current
  , updated
  , holdDyn
  , mapDynM
  , forDynM
  , constDyn
  , count
  , toggle
  , switchDyn
  , switchPromptlyDyn
  , tagPromptlyDyn
  , attachPromptlyDyn
  , attachPromptlyDynWith
  , attachPromptlyDynWithMaybe
  , maybeDyn
  , eitherDyn
  , factorDyn
  , scanDyn
  , scanDynMaybe
  , holdUniqDyn
  , holdUniqDynBy
  , improvingMaybe
  , foldDyn
  , foldDynM
  , foldDynMaybe
  , foldDynMaybeM
  , joinDynThroughMap
  , joinDynThroughIntMap
  , traceDyn
  , traceDynWith
  , splitDynPure
  , distributeMapOverDynPure
  , distributeIntMapOverDynPure
  , distributeDMapOverDynPure
  , distributeListOverDynPure
  , Demux
  , demux
  , demuxed
    -- * Miscellaneous
    -- Things that probably aren't very useful:
  , HList (..)
  , FHList (..)
  , collectDynPure
  , RebuildSortedHList (..)
  , IsHList (..)
  , AllAreFunctors (..)
  , HListPtr (..)
  , distributeFHListOverDynPure
    -- * Unsafe
  , unsafeDynamic
  ) where

import Data.Functor.Compose
import Data.Functor.Misc
import Reflex.Class

import Control.Monad
import Control.Monad.Fix
import Control.Monad.Identity
import Data.Align
import Data.Dependent.Map (DMap)
import qualified Data.Dependent.Map as DMap
import Data.Dependent.Sum (DSum (..))
import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Map (Map)
import Data.Maybe
import Data.Monoid ((<>))
import Data.These
import Data.Type.Equality ((:~:) (..))

import Debug.Trace

-- | Map a sampling function over a 'Dynamic'.
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 = buildDynamic (f =<< sample (current d)) $ pushAlways f (updated d)

-- | Flipped version of 'mapDynM'
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

-- | Create a new 'Dynamic' that only signals changes if the values actually
-- changed.
holdUniqDyn :: (Reflex t, MonadHold t m, MonadFix m, Eq a) => Dynamic t a -> m (Dynamic t a)
holdUniqDyn = holdUniqDynBy (==)

-- | Create a new 'Dynamic' that changes only when the underlying 'Dynamic'
-- changes and the given function returns 'False' when given both the old and
-- the new values.
holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)
holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new)

-- | @/Dynamic Maybe/@ that can only update from @/Nothing/@ to @/Just/@ or @/Just/@ to @/Just/@ (i.e., cannot revert to @/Nothing/@)
improvingMaybe :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe a))
improvingMaybe = scanDynMaybe id (\new _ -> if isJust new then Just new else Nothing)

-- | Create a 'Dynamic' that accumulates values from another 'Dynamic'.  This
-- function does not force its input 'Dynamic' until the output 'Dynamic' is
-- forced.
scanDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> b) -> Dynamic t a -> m (Dynamic t b)
scanDyn z f = scanDynMaybe z (\a b -> Just $ f a b)

-- | Like 'scanDyn', but the the accumulator function may decline to update the
-- result 'Dynamic''s value.
scanDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> Maybe b) -> Dynamic t a -> m (Dynamic t b)
scanDynMaybe z f d = do
  rec d' <- buildDynamic (z <$> sample (current d)) $ flip push (updated d) $ \a -> do
        b <- sample $ current d'
        return $ f a b
  return d'

-- | Create a 'Dynamic' using the initial value and change it each time the
-- 'Event' occurs using a folding function on the previous value and the value
-- of the 'Event'.
foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn = accumDyn . flip

-- | Like 'foldDyn', but the combining function is a 'PushM' action, so it
-- can 'sample' existing 'Behaviors' and 'hold' new ones.
foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
foldDynM = accumMDyn . flip

-- | Create a 'Dynamic' using the provided initial value and change it each time
-- the provided 'Event' occurs, using a function to combine the old value with
-- the 'Event''s value.  If the function returns 'Nothing', the value is not
-- changed; this is distinct from returning 'Just' the old value, since the
-- 'Dynamic''s 'updated' 'Event' will fire in the 'Just' case, and will not fire
-- in the 'Nothing' case.
foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)
foldDynMaybe = accumMaybeDyn . flip

-- | Like 'foldDynMaybe', but the combining function is a 'PushM' action, so it
-- can 'sample' existing 'Behaviors' and 'hold' new ones.
foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)
foldDynMaybeM = accumMaybeMDyn . flip

-- | Create a new 'Dynamic' that counts the occurrences of the 'Event'.
count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e

-- | Create a new 'Dynamic' using the initial value that flips its
-- value every time the 'Event' occurs.
toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)
toggle = foldDyn (const not)

-- | Switches to the new 'Event' whenever it receives one. Only the old event is
-- considered the moment a new one is switched in; the output event will fire at
-- that moment if only if the old event does.
--
-- Prefer this to 'switchPromptlyDyn' where possible. The lack of doing double
-- work when the outer and (new) inner fires means this imposes fewer "timing
-- requirements" and thus is far more easy to use without introducing fresh
-- failure cases. 'switchDyn' is also more performant.
switchDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
switchDyn d = switch (current d)

-- | Switches to the new 'Event' whenever it receives one.  Switching occurs
-- __before__ the inner 'Event' fires - so if the 'Dynamic' changes and both the
-- old and new inner Events fire simultaneously, the output will fire with the
-- value of the __new__ 'Event'.
--
-- Prefer 'switchDyn' to this where possible. The timing requirements that
-- switching before imposes are likely to bring down your app unless you are
-- very careful. 'switchDyn' is also more performant.
switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
switchPromptlyDyn de =
  let eLag = switch $ current de
      eCoincidences = coincidence $ updated de
  in leftmost [eCoincidences, eLag]

-- | Split a 'Dynamic' pair into a pair of 'Dynamic's
splitDynPure :: Reflex t => Dynamic t (a, b) -> (Dynamic t a, Dynamic t b)
splitDynPure d = (fmap fst d, fmap snd d)

-- | Convert a 'Map' with 'Dynamic' elements into a 'Dynamic' of a 'Map' with
-- non-'Dynamic' elements.
distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v)
distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap

-- | Convert an 'IntMap' with 'Dynamic' elements into a 'Dynamic' of an 'IntMap' with
-- non-'Dynamic' elements.
distributeIntMapOverDynPure :: (Reflex t) => IntMap (Dynamic t v) -> Dynamic t (IntMap v)
distributeIntMapOverDynPure = fmap dmapToIntMap . distributeDMapOverDynPure . intMapWithFunctorToDMap

-- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with
-- non-'Dynamic' elements, preserving the order of the elements.
{-# DEPRECATED distributeListOverDynPure "Use 'distributeListOverDyn' instead" #-}
distributeListOverDynPure :: Reflex t => [Dynamic t v] -> Dynamic t [v]
distributeListOverDynPure = distributeListOverDyn

--TODO: Generalize this to functors other than Maps
-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'
-- with the current values of the 'Dynamic's in a map.
joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
joinDynThroughMap = (distributeMapOverDynPure =<<)

-- | Combine a 'Dynamic' of an 'IntMap' of 'Dynamic's into a 'Dynamic'
-- with the current values of the 'Dynamic's in a map.
joinDynThroughIntMap :: forall t a. (Reflex t) => Dynamic t (IntMap (Dynamic t a)) -> Dynamic t (IntMap a)
joinDynThroughIntMap = (distributeIntMapOverDynPure =<<)

-- | Print the value of the 'Dynamic' when it is first read and on each
-- subsequent change that is observed (as 'traceEvent'), prefixed with the
-- provided string. This should /only/ be used for debugging.
--
-- Note: Just like Debug.Trace.trace, the value will only be shown if something
-- else in the system is depending on it.
traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a
traceDyn s = traceDynWith $ \x -> s <> ": " <> show x

-- | Print the result of applying the provided function to the value
-- of the 'Dynamic' when it is first read and on each subsequent change
-- that is observed (as 'traceEvent'). This should /only/ be used for
-- debugging.
--
-- Note: Just like Debug.Trace.trace, the value will only be shown if something
-- else in the system is depending on it.
traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a
traceDynWith f d =
  let e' = traceEventWith f $ updated d
      getV0 = do
        x <- sample $ current d
        trace (f x) $ return x
  in unsafeBuildDynamic getV0 e'

-- | Replace the value of the 'Event' with the current value of the 'Dynamic'
-- each time the 'Event' occurs.
--
-- Note: @/tagPromptlyDyn d e/@ differs from @/tag (current d) e/@ in the case that @/e/@ is firing
-- at the same time that @/d/@ is changing.  With @/tagPromptlyDyn d e/@, the __new__ value of @/d/@
-- will replace the value of @/e/@, whereas with @/tag (current d) e/@, the __old__ value
-- will be used, since the 'Behavior' won't be updated until the end of the frame.
-- Additionally, this means that the output 'Event' may not be used to directly change
-- the input 'Dynamic', because that would mean its value depends on itself.  __When creating__
-- __cyclic data flows, generally @/tag (current d) e/@ is preferred.__
tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
tagPromptlyDyn = attachPromptlyDynWith const

-- | Attach the current value of the 'Dynamic' to the value of the
-- 'Event' each time it occurs.
--
-- Note: @/attachPromptlyDyn d/@ is not the same as @/attach (current d)/@.  See 'tagPromptlyDyn' for details.
attachPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
attachPromptlyDyn = attachPromptlyDynWith (,)

-- | Combine the current value of the 'Dynamic' with the value of the
-- 'Event' each time it occurs.
--
-- Note: @/attachPromptlyDynWith f d/@ is not the same as @/attachWith f (current d)/@.  See 'tagPromptlyDyn' for details.
attachPromptlyDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b

-- | Create a new 'Event' by combining the value at each occurrence with the
-- current value of the 'Dynamic' value and possibly filtering if the combining
-- function returns 'Nothing'.
--
-- Note: @/attachPromptlyDynWithMaybe f d/@ is not the same as @/attachWithMaybe f (current d)/@.  See 'tagPromptlyDyn' for details.
attachPromptlyDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
attachPromptlyDynWithMaybe f d e =
  let e' = attach (current d) e
  in fforMaybe (align e' $ updated d) $ \case
       This (a, b) -> f a b -- Only the tagging event is firing, so use that
       These (_, b) a -> f a b -- Both events are firing, so use the newer value
       That _ -> Nothing -- The tagging event isn't firing, so don't fire

-- | Factor a @/Dynamic t (Maybe a)/@ into a @/Dynamic t (Maybe (Dynamic t a))/@,
-- such that the outer 'Dynamic' is updated only when the "Maybe"'s constructor
-- chages from 'Nothing' to 'Just' or vice-versa.  Whenever the constructor
-- becomes 'Just', an inner 'Dynamic' will be provided, whose value will track
-- the 'a' inside the 'Just'; when the constructor becomes 'Nothing', the
-- existing inner 'Dynamic' will become constant, and will not change when the
-- outer constructor changes back to 'Nothing'.
maybeDyn :: forall t a m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe (Dynamic t a)))
maybeDyn = fmap (fmap unpack) . eitherDyn . fmap pack
  where pack = \case
          Nothing -> Left ()
          Just a -> Right a
        unpack = \case
          Left _ -> Nothing
          Right a -> Just a

-- | Turns a 'Dynamic t (Either a b)' into a 'Dynamic t (Either (Dynamic t a) (Dynamic t b))' such that
-- the outer 'Dynamic' is updated only when the 'Either' constructor changes (e.g., from 'Left' to 'Right').
eitherDyn :: forall t a b m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Either a b) -> m (Dynamic t (Either (Dynamic t a) (Dynamic t b)))
eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum
  where unpack :: DSum (EitherTag a b) (Compose (Dynamic t) Identity) -> Either (Dynamic t a) (Dynamic t b)
        unpack = \case
          LeftTag :=> Compose a -> Left $ coerceDynamic a
          RightTag :=> Compose b -> Right $ coerceDynamic b

-- | Factor a 'Dynamic t DSum' into a 'Dynamic' 'DSum' containing nested 'Dynamic' values.
-- The outer 'Dynamic' updates only when the key of the 'DSum' changes, while the update of the inner
-- 'Dynamic' represents updates within the current key.
factorDyn :: forall t m k v. (Reflex t, MonadHold t m, GEq k)
          => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))
factorDyn d = buildDynamic (sample (current d) >>= holdKey) update  where
  update :: Event t (DSum k (Compose (Dynamic t) v))
  update = flip push (updated d) $ \(newKey :=> newVal) -> do
     (oldKey :=> _) <- sample (current d)
     case newKey `geq` oldKey of
      Just Refl -> return Nothing
      Nothing -> Just <$> holdKey (newKey :=> newVal)

  holdKey (k :=> v) = do
    inner' <- filterEventKey k (updated d)
    inner <- holdDyn v inner'
    return $ k :=> Compose inner

--------------------------------------------------------------------------------
-- Demux
--------------------------------------------------------------------------------

-- | Represents a time changing value together with an 'EventSelector' that can
-- efficiently detect when the underlying 'Dynamic' has a particular value.
-- This is useful for representing data like the current selection of a long
-- list.
--
-- Semantically,
--
-- > demuxed (demux d) k === fmap (== k) d
--
-- However, when 'demuxed' is used multiple times, the complexity is only
-- /O(log(n))/, rather than /O(n)/ for fmap.
data Demux t k = Demux { demuxValue :: Behavior t k
                       , demuxSelector :: EventSelector t (Const2 k Bool)
                       }

-- | Demultiplex an input value to a 'Demux' with many outputs.  At any given
-- time, whichever output is indicated by the given 'Dynamic' will be 'True'.
demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k
demux k = Demux (current k)
                (fan $ attachWith (\k0 k1 -> if k0 == k1
                                                then DMap.empty
                                                else DMap.fromList [Const2 k0 :=> Identity False,
                                                                    Const2 k1 :=> Identity True])
                                  (current k) (updated k))

-- | Select a particular output of the 'Demux'; this is equivalent to (but much
-- faster than) mapping over the original 'Dynamic' and checking whether it is
-- equal to the given key.
demuxed :: (Reflex t, Eq k) => Demux t k -> k -> Dynamic t Bool
demuxed d k =
  let e = select (demuxSelector d) (Const2 k)
  in unsafeBuildDynamic (fmap (==k) $ sample $ demuxValue d) e

--------------------------------------------------------------------------------
-- collectDyn
--------------------------------------------------------------------------------

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

-- | 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.
data HList (l::[*]) where
  HNil  :: HList '[]
  HCons :: e -> HList l -> HList (e ': l)

infixr 2 `HCons`

type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k]
type instance HRevApp '[] l = l
type instance HRevApp (e ': l) l' = HRevApp l (e ': l')

hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2)
hRevApp HNil l = l
hRevApp (HCons x l) l' = hRevApp l (HCons x l')

hReverse :: HList l -> HList (HRevApp l '[])
hReverse l = hRevApp l HNil

hBuild :: (HBuild' '[] r) => r
hBuild =  hBuild' HNil

class HBuild' l r where
    hBuild' :: HList l -> r

instance (l' ~ HRevApp l '[])
      => HBuild' l (HList l') where
  hBuild' = hReverse

instance HBuild' (a ': l) r
      => HBuild' l (a->r) where
  hBuild' l x = hBuild' (HCons x l)

-- | Like 'HList', but with a functor wrapping each element.
data FHList f l where
  FHNil :: FHList f '[]
  FHCons :: f e -> FHList f l -> FHList f (e ': l)

instance GEq (HListPtr l) where
  HHeadPtr `geq` HHeadPtr = Just Refl
  HHeadPtr `geq` HTailPtr _ = Nothing
  HTailPtr _ `geq` HHeadPtr = Nothing
  HTailPtr a `geq` HTailPtr b = a `geq` b

instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break
  HHeadPtr `gcompare` HHeadPtr = GEQ
  HHeadPtr `gcompare` HTailPtr _ = GLT
  HTailPtr _ `gcompare` HHeadPtr = GGT
  HTailPtr a `gcompare` HTailPtr b = a `gcompare` b

-- | A typed index into a typed heterogeneous list.
data HListPtr l a where
  HHeadPtr :: HListPtr (h ': t) h
  HTailPtr :: HListPtr t a -> HListPtr (h ': t) a

deriving instance Eq (HListPtr l a)
deriving instance Ord (HListPtr l a)

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]
        go = \case
          FHNil -> []
          FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> HTailPtr p :=> v) (go t)

-- | This class allows 'HList's and 'FHlist's to be built from regular lists;
-- they must be contiguous and sorted.
class RebuildSortedHList l where
  rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l
  rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l

instance RebuildSortedHList '[] where
  rebuildSortedFHList l = case l of
    [] -> FHNil
    _ : _ -> error "rebuildSortedFHList{'[]}: empty list expected"
  rebuildSortedHList l = case l of
    [] -> HNil
    _ : _ -> error "rebuildSortedHList{'[]}: empty list expected"

instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
  rebuildSortedFHList l = case l of
    ((HHeadPtr :=> h) : t) -> FHCons h . rebuildSortedFHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
    _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"
  rebuildSortedHList l = case l of
    ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
    _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"

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.
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.
class AllAreFunctors (f :: a -> *) (l :: [a]) where
  type FunctorList f l :: [*]
  toFHList :: HList (FunctorList f l) -> FHList f l
  fromFHList :: FHList f l -> HList (FunctorList f l)

instance AllAreFunctors f '[] where
  type FunctorList f '[] = '[]
  toFHList l = case l of
    HNil -> FHNil
#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
    _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
#endif
  fromFHList FHNil = HNil

instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
  type FunctorList f (h ': t) = f h ': FunctorList f t
  toFHList l = case l of
    a `HCons` b -> a `FHCons` toFHList b
#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
    _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
#endif
  fromFHList (a `FHCons` b) = a `HCons` fromFHList b

-- | 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
-- constituent 'Dynamic's.
collectDynPure :: ( RebuildSortedHList (HListElems b)
                  , IsHList a, IsHList b
                  , AllAreFunctors (Dynamic t) (HListElems b)
                  , Reflex t
                  , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
                  ) => a -> Dynamic t b
collectDynPure ds = fmap fromHList $ distributeFHListOverDynPure $ toFHList $ toHList ds

-- | Poor man's 'Generic's for product types only.
class IsHList a where
  type HListElems a :: [*]
  toHList :: a -> HList (HListElems a)
  fromHList :: HList (HListElems a) -> a

instance IsHList (a, b) where
  type HListElems (a, b) = [a, b]
  toHList (a, b) = hBuild a b
  fromHList l = case l of
    a `HCons` b `HCons` HNil -> (a, b)
#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

instance IsHList (a, b, c, d) where
  type HListElems (a, b, c, d) = [a, b, c, d]
  toHList (a, b, c, d) = hBuild a b c d
  fromHList l = case l of
    a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d)
#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

instance IsHList (a, b, c, d, e, f) where
  type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]
  toHList (a, b, c, d, e, f) = hBuild a b c d e f
  fromHList l = case l of
    a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f)
#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