lazy-rec-sample.cabal

name:                lazy-rec-sample
version:             0.1.0.0
-- synopsis:            
-- description:         
license:             BSD3
license-file:        LICENSE
author:              Christian Conkle
maintainer:          christian@conkle.org
-- copyright:           
-- category:            
build-type:          Simple
-- extra-source-files:  
cabal-version:       >=1.10

executable lazy-rec-sample
  main-is:             Main.hs
  -- other-modules:       
  other-extensions:    StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances, DeriveFunctor, GADTs, DataKinds, KindSignatures, TypeFamilies, PolyKinds, RankNTypes, ConstraintKinds, MultiParamTypeClasses, TypeOperators, ScopedTypeVariables, RecursiveDo, OverlappingInstances
  build-depends:       base >=4.6 && <4.7, transformers >=0.3 && <0.4
                     , vinyl == 0.2
                     , threepenny-gui >= 0.4 && <0.5
  -- hs-source-dirs:      
  default-language:    Haskell2010

Main.hs

{-# LANGUAGE StandaloneDeriving, FlexibleInstances, FlexibleContexts, UndecidableInstances, DeriveFunctor, GADTs, DataKinds, KindSignatures, TypeFamilies, PolyKinds, RankNTypes, ConstraintKinds, MultiParamTypeClasses, TypeOperators, ScopedTypeVariables, RecursiveDo, OverlappingInstances #-}
module Main where

import Data.Functor.Identity
import Data.Functor.Compose
import Data.Functor.Constant
import Data.Functor.Product
import Control.Applicative
import Data.Vinyl

import Graphics.UI.Threepenny.Core
import qualified Graphics.UI.Threepenny as TP

-- InputBuilder a ~ UI ([Element], Tidings a)
type InputBuilder = Compose UI (Product (Constant [Element]) Tidings)
-- WidgetBuilder a ~ Behavior a -> UI ([Element], Tidings a)
type WidgetBuilder = Behavior ~> InputBuilder

buildWidget :: (ApTraversable (LazyRec rs), SP rs)
           => LazyRec rs InputBuilder 
           -> UI (LazyRec rs (Constant [Element]), LazyRec rs Tidings)
buildWidget r = splitProduct <$> apTraverse getCompose r
           
ioString :: WidgetBuilder String
ioString = NT $ \output -> Compose $ do
    w <- TP.entry output
    return $ Pair (Constant [getElement w]) (TP.userText w)

class SP rs where
    splitProduct :: LazyRec rs (Product f g) -> ((LazyRec rs f), (LazyRec rs g))
instance SP '[] where
    splitProduct RNilL = (RNilL, RNilL)
instance SP rs => SP ((sy ::: t) ': rs) where
    splitProduct ~((:&~) ~(Pair l r) xs) = ((:&~) l (fst xs'), (:&~) r (snd xs'))
        where xs' = splitProduct xs 


type Name = "Name" ::: String
name :: Name
name = Field

type OtherField = "OtherField" ::: String
otherField :: OtherField
otherField = Field

type MyFields = '[Name, OtherField]

example :: Window -> UI ()
example w = do
    let builder :: LazyRec MyFields WidgetBuilder
        builder = ioString :&~ ioString :&~ RNilL
    rec
        -- These three blocks need to be in this order.
        -- I think that you can't evaluate tidings at all until after the first line?
        
        (elements, tidings) <- buildWidget (builder <<*>> output)
        let nameT = rGetL' name tidings
            otherFieldT = rGetL' otherField tidings
            -- This is silly, but demonstrates that we can use the individual
            -- fields within the rec block. 
            -- Note that each behavior is based on the 'wrong' rumors.
            behaviors :: LazyRec MyFields (Compose UI Behavior)
            behaviors = (Compose $ stepper "Name?" (rumors otherFieldT)) 
                         :&~ (Compose $ stepper "OtherField?" (rumors nameT)) :&~ RNilL
        output <- apTraverse getCompose behaviors
        
    let (Constant nameElems) = rGetL' name elements
        (Constant otherFieldElems) = rGetL' otherField elements
    _ <- getBody w #+ 
      [ grid
        [ [ TP.div #+ (fmap return $ nameElems)
          , TP.div #+ (fmap return $ otherFieldElems)
          ]
        , [ TP.span # sink text (facts nameT)
          , TP.span # sink text (facts otherFieldT)
          ]
        ]
      ]
    return ()

main :: IO ()
main = TP.startGUI TP.defaultConfig example
    
--
-- Orphan instance
--

instance Applicative TP.UI where
    pure = return
    ff <*> fs = ff >>= \ f -> fs >>= \ s -> return (f s)
    
--
-- LazyRec implementation
--
data Elem' :: * -> [*] -> * where
  Here' :: Elem' x (x ': xs)
  There' :: (y ~ (sy ::: t)) => Elem' x xs -> Elem' x (y ': xs)

instance Implicit (Elem' x (x ': xs)) where
  implicitly = Here'
instance (y ~ (sy ::: t), Implicit (Elem' x xs)) => Implicit (Elem' x (y ': xs)) where
  implicitly = There' implicitly

type IElem' x xs = Implicit (Elem' x xs)

-- | Project a field from a 'Rec'.
rGetL' :: IElem' (sy ::: t) rs => (sy ::: t) -> LazyRec rs f -> f t
rGetL' r = getConst . rLensL' r Const
{-# INLINE rGetL' #-}

-- | Project a field from a 'PlainRec'.
rGetL :: IElem' (sy ::: t) rs => (sy ::: t) -> LazyRec rs Identity -> t
rGetL = (runIdentity .) . rGetL'
{-# INLINE rGetL #-}

-- | Set a field in a 'Rec' over an arbitrary functor.
rPutL' :: IElem' (sy ::: t) rs => (sy ::: t) -> f t -> LazyRec rs f -> LazyRec rs f
rPutL' r x = runIdentity . rLensL' r (Identity . const x)
{-# INLINE rPutL' #-}

-- | Set a field in a 'PlainRec'.
rPutL :: IElem' (sy:::t) rs => (sy:::t) -> t -> LazyRec rs Identity -> LazyRec rs Identity
rPutL r x = rPutL' r (Identity x)
{-# INLINE rPutL #-}

-- | Modify a field.
rModL :: (IElem' (sy:::t) rs, Functor f)
     => (sy:::t) -> (t -> t) -> LazyRec rs f -> LazyRec rs f
rModL r f = runIdentity . rLensL' r (Identity . fmap f)
{-# INLINE rModL #-}

-- We manually unroll several levels of 'Elem' value traversal to help
-- GHC statically index into small records.

-- | Provide a lens to a record field. Note that this implementation
-- does not support polymorphic update. In the parlance of the @lens@
-- package,
--
-- > rLensL' :: IElem' (sy:::t) rs => (sy:::t) -> Lens' (LazyRec rs f) (f t)
rLensL' :: forall r rs sy t f g. (r ~ (sy:::t), Implicit (Elem' r rs), Functor g)
       => r -> (f t -> g (f t)) -> LazyRec rs f -> g (LazyRec rs f)
rLensL' _ f = go implicitly
  where 
    go :: Elem' r rr -> LazyRec rr f -> g (LazyRec rr f)
    go Here' ~(x :&~ xs) = fmap (:&~ xs) (f x)
    go (There' Here') ~(a :&~ x :&~ xs) = fmap ((a :&~) . (:&~ xs)) (f x)
    go (There' (There' Here')) ~(a :&~ b :&~ x :&~ xs) =
      fmap (\x' -> a :&~ b :&~ x' :&~ xs) (f x)
    go (There' (There' (There' Here'))) ~(a :&~ b :&~ c :&~ x :&~ xs) =
      fmap (\x' -> a :&~ b :&~ c :&~ x' :&~ xs) (f x)
    go (There' (There' (There' (There' Here')))) ~(a :&~ b :&~ c :&~ d :&~ x :&~ xs) =
      fmap (\x' -> a :&~ b :&~ c :&~ d :&~ x' :&~ xs) (f x)
    go (There' (There' (There' (There' p)))) ~(a :&~ b :&~ c :&~ d :&~ xs) =
      fmap (\xs' -> a :&~ b :&~ c :&~ d :&~ xs') (go' p xs)
    {-# INLINE go #-}

    go' :: Elem' r rr -> LazyRec rr f -> g (LazyRec rr f)
    go' Here' ~(x :&~ xs) = fmap (:&~ xs) (f x)
    go' (There' p) ~(x :&~ xs) = fmap (x :&~) (go p xs)
    {-# INLINABLE go' #-}
{-# INLINE rLensL' #-}

-- | A lens into a 'PlainRec' that smoothly interoperates with lenses
-- from the @lens@ package. Note that polymorphic update is not
-- supported. In the parlance of the @lens@ package,
-- 
-- > rLensL :: IElem' (sy:::t) rs => (sy:::t) -> Lens' (LazyRec rs Identity) t
rLensL :: forall r rs sy t g. (r ~ (sy:::t), IElem' r rs, Functor g)
      => r -> (t -> g t) -> LazyRec rs Identity -> g (LazyRec rs Identity)
rLensL r = rLensL' r . lenser runIdentity (const Identity)
  where lenser sa sbt afb s = sbt s <$> afb (sa s)
{-# INLINE rLensL #-}

data family LazyRec (rs :: [*]) (f :: (* -> *)) :: *
data instance LazyRec '[] f = RNilL
data instance LazyRec ((sy ::: t) ': rs) f =  f t :&~ LazyRec rs f

infixr :&~

deriving instance Show (LazyRec '[] f)
deriving instance (Show (LazyRec rs f), Show (f t)) => Show (LazyRec ((sy ::: t) ': rs) f)    

instance Eq (LazyRec '[] f) where
  _ == _ = True
instance (Eq (g t), Eq (LazyRec fs g)) => Eq (LazyRec ((s ::: t) ': fs) g) where
  ~(x :&~ xs) == ~(y :&~ ys) = (x == y) && (xs == ys)
  
class ToRec rs f where
  toRec :: LazyRec rs f -> Rec rs f
instance ToRec '[] f where
  toRec RNilL = RNil
instance ToRec rs f => ToRec ((sy ::: t) ': rs) f where
  toRec (x :&~ xs) = x :& toRec xs
    
class FromRec rs f where
  fromRec :: Rec rs f -> LazyRec rs f
instance FromRec '[] f where
  fromRec RNil = RNilL
instance FromRec rs f => FromRec ((sy ::: t) ': rs) f where
  fromRec (x :& xs) = x :&~ (fromRec xs)

class ApFunctor (f :: (k -> *) -> *) where
    (<<$>>) :: forall (g :: k -> *) (h :: k -> *). 
              (forall (x :: k). g x -> h x) -> f g -> f h

class (ApFunctor f) => ApTraversable (f :: (k -> *) -> *) where
    apTraverse :: forall (g :: k -> *) (h :: k -> *) (e :: * -> *).
                  (Applicative e) =>
                  (forall (x :: k). g x -> e (h x)) -> f g -> e (f h)

instance ApFunctor (LazyRec '[]) where
  _  <<$>> _      = RNilL
instance ApFunctor (LazyRec rs) => ApFunctor (LazyRec ((sy ::: t) ': rs)) where
  nat <<$>> ~((:&~) x xs) = (:&~) (nat x) (nat <<$>> xs)
  
instance ApTraversable (LazyRec '[]) where
  apTraverse _ _      = pure RNilL -- should we pattern match on the RNilL?
instance ApTraversable (LazyRec rs) => ApTraversable (LazyRec ((sy ::: t) ': rs)) where
  apTraverse m ((:&~) x xs) = (:&~) <$> (m x) <*> apTraverse m xs
  

instance Apply (~>) (LazyRec '[]) where
  _ <<*>> _ = RNilL -- again, pattern match?
instance Apply (~>) (LazyRec rs) => Apply (~>) (LazyRec ((sy ::: t) ': rs)) where
  ~(f :&~ fs) <<*>> ~(x :&~ xs) = runNT f x :&~ (fs <<*>> xs)