forms experimentation type family

cleaner-forms.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}

import           Data.Bifunctor
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import           Text.Read

data HtmlT (m :: * -> *) a

data Form index a where
  -- Values
  PureValue :: FormMonad index a -> Form index a
  MapValue :: (a -> b) -> Form index a -> Form index b
  ApValue :: Form index (a -> b) -> Form index a -> Form index b
  -- Views
  PureView :: FormMonad index (View index) -> Form index a
  MapView :: (View index -> View index') -> Form index a -> Form index' a
  -- Fields
  PureField :: FormMonad index (Field index a) -> Form index a
  -- Validation/errors
  Validate :: (a -> FormMonad index (Either (Error index) b)) -> Form index a -> Form index b
  MapError :: (Error index -> Error index') -> Form index a -> Form index' a

instance Functor (Form i) where fmap = MapValue
instance (FormMonadic i, Monad (FormMonad i)) => Applicative (Form i) where
  (<*>) = ApValue
  pure = PureValue . pure

class FormField index a where
  type Field index a

class FormMonadic index where
   type FormMonad index :: * -> *

class FormView index where
   type View index

class FormError index where
   type Error index

data App
data MyError = GeneralError String
instance FormView App where type View App = HtmlT IO ()
instance FormError App where type Error App = MyError
instance FormMonadic App where type FormMonad App = IO
instance FormField App ty where type Field App ty = AppField ty
data AppField a where TextField :: AppField String

data WiderApp
data WiderError = MyError MyError
instance FormView WiderApp where type View WiderApp = HtmlT IO ()
instance FormError WiderApp where type Error WiderApp = WiderError
instance FormMonadic WiderApp where type FormMonad WiderApp = IO

demo :: Form WiderApp Int
demo = mapView (\x -> x) $ MapError MyError demoinner

demoinner :: Form App Int
demoinner = Validate (pure . first GeneralError . readEither) (PureField (pure TextField))

mapView ::
     (View index -> View index)
  -> Form index a
  -> Form index a
mapView = MapView